aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.travis.yml107
-rw-r--r--README.md6
-rw-r--r--haddock-api/haddock-api.cabal4
-rw-r--r--haddock-api/src/Haddock.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs135
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs222
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Convert.hs35
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs8
-rw-r--r--haddock-api/src/Haddock/Options.hs5
-rw-r--r--haddock-test/src/Test/Haddock.hs44
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs5
-rw-r--r--haddock-test/src/Test/Haddock/Process.hs14
-rw-r--r--haddock.cabal2
-rw-r--r--html-test/ref/TypeFamilies3.html356
-rw-r--r--html-test/ref/UnboxedStuff.html196
-rw-r--r--html-test/src/TypeFamilies3.hs21
-rw-r--r--html-test/src/UnboxedStuff.hs18
-rw-r--r--latex-test/ref/TypeFamilies3/TypeFamilies3.tex44
-rw-r--r--latex-test/ref/TypeFamilies3/haddock.sty57
-rw-r--r--latex-test/ref/TypeFamilies3/main.tex11
-rw-r--r--latex-test/ref/UnboxedStuff/UnboxedStuff.tex36
-rw-r--r--latex-test/ref/UnboxedStuff/haddock.sty57
-rw-r--r--latex-test/ref/UnboxedStuff/main.tex11
-rw-r--r--latex-test/src/TypeFamilies3/TypeFamilies3.hs21
-rw-r--r--latex-test/src/UnboxedStuff/UnboxedStuff.hs18
28 files changed, 1219 insertions, 250 deletions
diff --git a/.travis.yml b/.travis.yml
index 681399b9..2bcb301a 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,8 +1,8 @@
# This Travis job script has been generated by a script via
#
-# runghc make_travis_yml_2.hs 'haddock.cabal'
+# make_travis_yml_2.hs 'haddock.cabal'
#
-# For more information, see https://github.com/haskell-CI/haskell-ci
+# For more information, see https://github.com/hvr/multi-ghc-travis
#
language: c
sudo: false
@@ -28,63 +28,70 @@ before_cache:
matrix:
include:
- - compiler: "ghc-8.6.1"
+ - compiler: "ghc-head"
+ env: GHCHEAD=true
# env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}
+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}
before_install:
- - HC=${CC}
- - HCPKG=${HC/ghc/ghc-pkg}
- - unset CC
- - ROOTDIR=$(pwd)
- - mkdir -p $HOME/.local/bin
- - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
- - echo $HCNUMVER
+ - HC=${CC}
+ - HCPKG=${HC/ghc/ghc-pkg}
+ - unset CC
+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
+ - PKGNAME='haddock'
install:
- - cabal --version
- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
- - BENCH=${BENCH---enable-benchmarks}
- - TEST=${TEST---enable-tests}
- - HADDOCK=${HADDOCK-true}
- - UNCONSTRAINED=${UNCONSTRAINED-true}
- - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
- - GHCHEAD=${GHCHEAD-false}
- - travis_retry cabal update -v
- - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
- - rm -fv cabal.project.local
- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
- - touch cabal.project.local
- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- haddock | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
- - cat cabal.project || true
- - cat cabal.project.local || true
- - if [ -f "./configure.ac" ]; then
- (cd "." && autoreconf -i);
- fi
- - rm -f cabal.project.freeze
- - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
- - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
- - rm -rf .ghc.environment.* "."/dist
- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
+ - cabal --version
+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - BENCH=${BENCH---enable-benchmarks}
+ - TEST=${TEST---enable-tests}
+ - GHCHEAD=${GHCHEAD-false}
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - rm -fv cabal.project.local
+ - rm -f cabal.project.freeze
+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage
+ - |
+ if $GHCHEAD; then
+ sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config
+ for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done
+
+ echo 'repository head.hackage' >> ${HOME}/.cabal/config
+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config
+ echo ' secure: True' >> ${HOME}/.cabal/config
+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config
+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config
+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config
+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config
+
+ grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
+
+ cabal new-update head.hackage -v
+ fi
+ - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all
+ - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all
# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
script:
- - cat cabal.project || true
- - cat cabal.project.local || true
- # this builds all libraries and executables (without tests/benchmarks)
- - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
-
- # build & run tests, build benchmarks
- - cabal new-build -w ${HC} ${TEST} ${BENCH} all
- - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
-
- # cabal check
- - cabal check
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - rm -rf dist/
+ - cabal sdist # test that a source-distribution can be generated
+ - cd dist/
+ - SRCTAR=(${PKGNAME}-*.tar.gz)
+ - SRC_BASENAME="${SRCTAR/%.tar.gz}"
+ - tar -xvf "./$SRC_BASENAME.tar.gz"
+ - cd "$SRC_BASENAME/"
+## from here on, CWD is inside the extracted source-tarball
+ - rm -fv cabal.project.local
+ # this builds all libraries and executables (without tests/benchmarks)
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --allow-newer --constraint 'setup.Cabal installed' all
+ # this builds all libraries and executables (including tests/benchmarks)
+ # - rm -rf ./dist-newstyle
- # Build without installed constraints for packages in global-db
- - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
+ # build & run tests
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer --constraint 'setup.Cabal installed' all
+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer --constraint 'setup.Cabal installed' all; fi
-# REGENDATA ["haddock.cabal"]
# EOF
diff --git a/README.md b/README.md
index 38354996..978dea3e 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-8.6)](https://travis-ci.org/haskell/haddock)
+# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-head)](https://travis-ci.org/haskell/haddock)
## About haddock
@@ -57,9 +57,9 @@ and then proceed using your favourite build tool.
#### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html)
```bash
-cabal new-build -w ghc-8.6.1
+cabal new-build -w ghc-head
# build & run the test suite
-cabal new-test -w ghc-8.6.1 all
+cabal new-test -w ghc-head all
```
#### Using Cabal sandboxes
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index fa14eb50..c262f975 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -42,7 +42,7 @@ library
-- this package typically supports only single major versions
build-depends: base ^>= 4.12.0
, Cabal ^>= 2.4.0
- , ghc ^>= 8.6
+ , ghc ^>= 8.7
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.7.0
, xhtml ^>= 3000.2.2
@@ -167,7 +167,7 @@ test-suite spec
Haddock.Backends.Hyperlinker.Types
build-depends: Cabal ^>= 2.4
- , ghc ^>= 8.6
+ , ghc ^>= 8.7
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.7.0
, xhtml ^>= 3000.2.2
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dbfba0f4..8c0ae705 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -161,16 +161,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ -- bypass the interface version check
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
unless (Flag_NoWarnings `elem` flags) $ do
hypSrcWarnings flags
forM_ (warnings args) $ \warning -> do
hPutStrLn stderr warning
+ when noChecks $
+ hPutStrLn stderr noCheckWarning
ghc flags' $ do
dflags <- getDynFlags
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+ mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
@@ -192,7 +197,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep dflags flags sinceQual qual packages []
@@ -203,6 +208,10 @@ warnings = map format . filter (isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+-- | Create a warning about bypassing the interface version check
+noCheckWarning :: String
+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
+ "Haddock to crash when reading Haddock interface files."
withGhc :: [Flag] -> Ghc a -> IO a
withGhc flags action = do
@@ -220,7 +229,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map snd packages
@@ -404,13 +414,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
readInterfaceFiles :: MonadIO m
=> NameCacheAccessor m
-> [(DocPaths, FilePath)]
+ -> Bool
-> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file >>= \case
+ readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index acb2c892..f8494242 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =
-- A Haskell line comment
then case span (/= '\n') str' of
(str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)
- (_, _) -> (str, "")
+ (_, _) -> (str, "")
-- An actual Haskell token
else let (str'', rest) = spanToNewline 0 str'
@@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
go :: (RealSrcLoc, [T.Token], Bool)
-- ^ current position, tokens accumulated, currently in pragma (or not)
-
+
-> (Located L.Token, String)
-- ^ next token, its content
-
+
-> (RealSrcLoc, [T.Token], Bool)
-- ^ new position, new tokens accumulated, currently in pragma (or not)
@@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
)
where
(next_pos, white) = mkWhitespace pos l
-
+
classifiedTok = [ Token (classify' tok) raw rss
| RealSrcSpan rss <- [l]
, not (null raw)
]
-
+
classify' | in_prag = const TkPragma
| otherwise = classify
@@ -378,6 +378,7 @@ classify tok =
ITLarrowtail {} -> TkGlyph
ITRarrowtail {} -> TkGlyph
+ ITcomment_line_prag -> TkUnknown
ITunknown {} -> TkUnknown
ITeof -> TkUnknown
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4a3e9d03..0c7747bd 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -12,10 +12,9 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.LaTeX (
- ppLaTeX
+ ppLaTeX,
) where
-
import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
@@ -285,7 +284,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode
TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
@@ -303,12 +302,6 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
unicode = False
-ppTyFam :: Bool -> Documentation DocName ->
- TyClDecl DocNameI -> Bool -> LaTeX
-ppTyFam _ _ _ _ =
- error "type family declarations are currently not supported by --latex"
-
-
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
ppFunSig doc [name] (hsSigType typ) unicode
@@ -317,6 +310,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-------------------------------------------------------------------------------
+-- * Type families
+-------------------------------------------------------------------------------
+
+-- | Pretty-print a data\/type family declaration
+ppFamDecl :: Documentation DocName -- ^ this decl's docs
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> TyClDecl DocNameI -- ^ family to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamDecl doc instances decl unicode =
+ declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit)
+ (if null body then Nothing else Just (vcat body))
+ $$ instancesBit
+ where
+ body = catMaybes [familyEqns, documentationToLaTeX doc]
+
+ whereBit = case fdInfo (tcdFam decl) of
+ ClosedTypeFamily _ -> keyword "where"
+ _ -> empty
+
+ familyEqns
+ | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
+ = Just (text "\\haddockbeginargs" $$
+ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
+ text "\\end{tabulary}\\par")
+ | otherwise = Nothing
+
+ -- Individual equations of a closed type family
+ ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
+ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts } })
+ = hsep [ ppAppNameTypes n (map unLoc ts) unicode
+ , equals
+ , ppType unicode (unLoc rhs)
+ ]
+ ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
+
+ instancesBit = ppDocInstances unicode instances
+
+-- | Print the LHS of a type\/data family declaration.
+ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader"
+ppFamHeader (FamilyDecl { fdLName = L _ name
+ , fdTyVars = tvs
+ , fdInfo = info
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
+ unicode =
+ leader <+> keyword "family" <+> famName <+> famSig <+> injAnn
+ where
+ leader = case info of
+ OpenTypeFamily -> keyword "type"
+ ClosedTypeFamily _ -> keyword "type"
+ DataFamily -> keyword "data"
+
+ famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
+
+ famSig = case result of
+ NoSig _ -> empty
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr
+ XFamilyResultSig _ -> panic "haddock:ppFamHeader"
+
+ injAnn = case injectivity of
+ Nothing -> empty
+ Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")
+ : ppLDocName lhs
+ : arrow unicode
+ : map ppLDocName rhs)
+
+
+
+-------------------------------------------------------------------------------
-- * Type Synonyms
-------------------------------------------------------------------------------
@@ -538,12 +608,14 @@ ppClassDecl instances doc subdocs
| otherwise = error "LaTeX.ppClassDecl"
methodTable =
- text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
+ text "\\haddockpremethods{}" <> emph (text "Methods") $$
+ vcat [ ppFunSig doc names (hsSigWcType typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
- , name <- map unLoc lnames
- , let doc = lookupAnySubdoc name subdocs
- ]
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
instancesBit = ppDocInstances unicode instances
@@ -573,14 +645,13 @@ ppDocInstance unicode (instHead, doc, _, _) =
ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
-ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
-
-
-ppInstHead :: Bool -> InstHead DocNameI -> LaTeX
-ppInstHead unicode (InstHead {..}) = case ihdInstType of
- ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
- TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
- DataInst _ -> error "data instances not supported by --latex yet"
+ppInstDecl unicode (InstHead {..}) = case ihdInstType of
+ ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ
+ TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs
+ DataInst dd ->
+ let nd = dd_ND (tcdDataDefn dd)
+ pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
+ in pref <+> keyword "instance" <+> typ
where
typ = ppAppNameTypes ihdClsName ihdTypes unicode
tibody = maybe empty (\t -> equals <+> ppType unicode t)
@@ -613,7 +684,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
+ body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]
(whereBit, leaders)
| null cons
@@ -823,6 +894,12 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
-- * Type applications
--------------------------------------------------------------------------------
+ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
+ppAppDocNameTyVarBndrs unicode n vs =
+ ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
+ where
+ ppDN = ppBinder . nameOccName . getName
+
-- | Print an application of a DocName to its list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
@@ -897,7 +974,7 @@ tupleParens _ = parenList
sumParens :: [LaTeX] -> LaTeX
-sumParens = ubxparens . hsep . punctuate (text " | ")
+sumParens = ubxparens . hsep . punctuate (text " |")
-------------------------------------------------------------------------------
@@ -917,6 +994,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
+ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
+ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
+ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
+ parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
+
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
@@ -973,7 +1056,7 @@ ppr_mono_ty (HsParTy _ ty) unicode
ppr_mono_ty (HsDocTy _ ty _) unicode
= ppr_mono_lty ty unicode
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_'
+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_"
ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
@@ -1252,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma
ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
+ubxparens h = text "(#" <+> h <+> text "#)"
nl :: LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index cc271fef..12e65716 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -15,9 +15,7 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Decl (
ppDecl,
-
- ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,
- tyvarNames
+ ppOrphanInstances,
) where
import Haddock.Backends.Xhtml.DocMarkup
@@ -56,7 +54,7 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
- TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+ TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual
TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
@@ -67,7 +65,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -222,9 +220,6 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
-tyvarNames :: LHsQTyVars DocNameI -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
-
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
@@ -283,111 +278,111 @@ ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
--------------------------------------------------------------------------------
-ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html
-ppFamilyInfo assoc OpenTypeFamily
- | assoc = keyword "type"
- | otherwise = keyword "type family"
-ppFamilyInfo assoc DataFamily
- | assoc = keyword "data"
- | otherwise = keyword "data family"
-ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
-
-
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI
- -> Unicode -> Qualification -> Html
-ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdResultSig = L _ result
- , fdInjectivityAnn = injectivity })
- unicode qual =
- (case info of
- OpenTypeFamily
- | associated -> keyword "type"
- | otherwise -> keyword "type family"
- DataFamily
- | associated -> keyword "data"
- | otherwise -> keyword "data family"
- ClosedTypeFamily _
- -> keyword "type family"
- ) <+>
-
- ppFamDeclBinderWithVars summary unicode qual d <+>
- ppResultSig result unicode qual <+>
-
- (case injectivity of
- Nothing -> noHtml
- Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
- ) <+>
-
- (case info of
- ClosedTypeFamily _ -> keyword "where ..."
- _ -> mempty
- )
-ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
-
-ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
-ppResultSig result unicode qual = case result of
- NoSig _ -> noHtml
- KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- XFamilyResultSig _ -> panic "haddock:ppResultSig"
-
-ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
- -> Html
-ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
- ppFamilyInfo True pfdInfo <+>
- ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
- ppResultSig (unLoc pfdKindSig) unicode qual
-
-ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html
-ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
- char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>
- hsep (map (ppLDocName qual Raw) rhs)
-
-
-ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
- [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->
- Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl splice unicode
- pkg qual
-
- | summary = ppTyFamHeader True associated decl unicode qual
+-- | Print a data\/type family declaration
+ppFamDecl :: Bool -- ^ is a summary
+ -> Bool -- ^ is an associated type
+ -> LinksInfo
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> [(DocName, Fixity)] -- ^ relevant fixities
+ -> SrcSpan
+ -> Documentation DocName -- ^ this decl's documentation
+ -> FamilyDecl DocNameI -- ^ this decl
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual
+ | summary = ppFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit
where
docname = unLoc $ fdLName decl
header_ = topDeclElem links loc splice [docname] $
- ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
+ ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
instancesBit
| FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
, not summary
- = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
+ = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns
| otherwise
= ppInstances links (OriginFamily docname) instances splice unicode pkg qual
-- Individual equation of a closed type family
- ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
- ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
- , feqn_pats = ts } })
- = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+ ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl
+ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts } })
+ = ( ppAppNameTypes n (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
- , Nothing, [] )
- ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
- ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
-
+ , Nothing
+ , []
+ )
+ ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
-ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
- -> PseudoFamilyDecl DocNameI
- -> Html
-ppPseudoFamilyDecl links splice unicode qual
- decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
- wrapper $ ppPseudoFamilyHeader unicode qual decl
+-- | Print a pseudo family declaration
+ppPseudoFamDecl :: LinksInfo -> Splice
+ -> PseudoFamilyDecl DocNameI -- ^ this decl
+ -> Unicode -> Qualification -> Html
+ppPseudoFamDecl links splice
+ (PseudoFamilyDecl { pfdInfo = info
+ , pfdKindSig = L _ kindSig
+ , pfdTyVars = tvs
+ , pfdLName = L loc name })
+ unicode qual =
+ topDeclElem links loc splice [name] leader
+ where
+ leader = hsep [ ppFamilyLeader True info
+ , ppAppNameTypes name (map unLoc tvs) unicode qual
+ , ppResultSig kindSig unicode qual
+ ]
+
+-- | Print the LHS of a type\/data family declaration
+ppFamHeader :: Bool -- ^ is a summary
+ -> Bool -- ^ is an associated type
+ -> FamilyDecl DocNameI -- ^ family declaration
+ -> Unicode -> Qualification -> Html
+ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"
+ppFamHeader summary associated (FamilyDecl { fdInfo = info
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity
+ , fdLName = L _ name
+ , fdTyVars = tvs })
+ unicode qual =
+ hsep [ ppFamilyLeader associated info
+ , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs)
+ , ppResultSig result unicode qual
+ , injAnn
+ , whereBit
+ ]
where
- wrapper = topDeclElem links loc splice [name]
+ whereBit = case info of
+ ClosedTypeFamily _ -> keyword "where ..."
+ _ -> noHtml
+
+ injAnn = case injectivity of
+ Nothing -> noHtml
+ Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"
+ : ppLDocName qual Raw lhs
+ : arrow unicode
+ : map (ppLDocName qual Raw) rhs)
+
+-- | Print the keywords that begin the family declaration
+ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html
+ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family")
+ where
+ typ = case info of
+ OpenTypeFamily -> "type"
+ ClosedTypeFamily _ -> "type"
+ DataFamily -> "data"
+
+-- | Print the signature attached to a family
+ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+ NoSig _ -> noHtml
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ XFamilyResultSig _ -> panic "haddock:ppResultSig"
--------------------------------------------------------------------------------
@@ -399,25 +394,10 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
-> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
+ ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual
--------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
--- | Print a type family and its variables
-ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
-ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
- ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
-ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
-
--- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
-ppDataBinderWithVars summ unicode qual decl =
- ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
-
---------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
@@ -672,7 +652,9 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m
, mdoc
, [subFamInstDetails iid pdecl mname])
where
- pdata = keyword "data" <+> typ
+ nd = dd_ND (tcdDataDefn dd)
+ pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
+ pdata = pref <+> typ
pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
@@ -684,9 +666,7 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
-> [PseudoFamilyDecl DocNameI]
-> [Html]
ppInstanceAssocTys links splice unicode qual =
- map ppFamilyDecl'
- where
- ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
+ map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual)
ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
@@ -1060,10 +1040,12 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
-ppDataHeader summary decl@(DataDecl { tcdDataDefn =
- HsDataDefn { dd_ND = nd
- , dd_ctxt = ctxt
- , dd_kindSig = ks } })
+ppDataHeader summary (DataDecl { tcdDataDefn =
+ HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt
+ , dd_kindSig = ks }
+ , tcdLName = L _ name
+ , tcdTyVars = tvs })
unicode qual
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
@@ -1071,7 +1053,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
-- context
ppLContext ctxt unicode qual HideEmptyContexts <+>
-- T a b c ..., or a :+: b
- ppDataBinderWithVars summary unicode qual decl
+ ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs)
<+> case ks of
Nothing -> mempty
Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
@@ -1120,7 +1102,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
-ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"
+ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 7fbaec6d..62781fd0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
dcolon, arrow, darrow, forallSymbol :: Bool -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6eee353b..f8c26175 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -36,9 +36,10 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey
- , tYPETyConKey, liftedRepDataConKey )
+import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
+ , unitTy, promotedNilDataCon, promotedConsDataCon )
+import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
+ , liftedRepDataConKey )
import Unique ( getUnique )
import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
, splitAtList )
@@ -118,8 +119,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
+ in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExt
, feqn_tycon = name
, feqn_pats = annot_typats
@@ -457,9 +457,24 @@ synifyType _ (TyConApp tc tys)
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) vis_tys)
+ | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys)
+ | Just dc <- isPromotedDataCon_maybe tc
+ , isTupleDataCon dc
+ , dataConSourceArity dc == length vis_tys
+ = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys)
-- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
+ | getName tc == listTyConName, [ty] <- vis_tys =
noLoc $ HsListTy noExt (synifyType WithinType ty)
+ | tc == promotedNilDataCon, [] <- vis_tys
+ = noLoc $ HsExplicitListTy noExt Promoted []
+ | tc == promotedConsDataCon
+ , [ty1, ty2] <- vis_tys
+ = let hTy = synifyType WithinType ty1
+ in case synifyType WithinType ty2 of
+ tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy
+ -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy')
+ | otherwise
+ -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
@@ -567,6 +582,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig k = synifyType WithinType k
+stripKindSig :: LHsType GhcRn -> LHsType GhcRn
+stripKindSig (L _ (HsKindSig _ t _)) = t
+stripKindSig t = t
+
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
@@ -652,8 +671,8 @@ tcSplitSigmaTyPreserveSynonyms ty =
tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)
tcSplitForAllTysPreserveSynonyms ty = split ty ty []
where
- split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..351a39d1 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -23,7 +23,7 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
import Control.Monad hiding (mapM)
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index ce6ecc78..30bd2b9a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807)
+#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
binaryInterfaceVersion = 33
binaryInterfaceVersionCompatibility :: [Word16]
@@ -190,8 +190,9 @@ readInterfaceFile :: forall m.
MonadIO m
=> NameCacheAccessor m
-> FilePath
+ -> Bool -- ^ Disable version check. Can cause runtime crash.
-> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
+readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
bh0 <- liftIO $ readBinMem filename
magic <- liftIO $ get bh0
@@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
"Magic number mismatch: couldn't load interface file: " ++ filename
- | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+ | not bypass_checks
+ , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
"Interface file is of wrong version: " ++ filename
| otherwise -> with_name_cache $ \update_nc -> do
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b5e987d8..46db572b 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -84,6 +84,7 @@ data Flag
| Flag_Version
| Flag_CompatibleInterfaceVersions
| Flag_InterfaceVersion
+ | Flag_BypassInterfaceVersonCheck
| Flag_UseContents String
| Flag_GenContents
| Flag_UseIndex String
@@ -175,6 +176,8 @@ options backwardsCompat =
"output compatible interface file versions and exit",
Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
"output interface file version and exit",
+ Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
+ "bypass the interface file version check (dangerous)",
Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
"set verbosity level",
Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
@@ -186,7 +189,7 @@ options backwardsCompat =
Option [] ["gen-index"] (NoArg Flag_GenIndex)
"generate an HTML index from specified\ninterfaces",
Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports atribute",
+ "behave as if all modules have the\nignore-exports attribute",
Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
"behave as if MODULE has the hide attribute",
Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 942c0587..25c64cfe 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -34,12 +34,12 @@ data CheckResult
runAndCheck :: Config c -> IO ()
runAndCheck cfg = do
- runHaddock cfg
- checkFiles cfg
+ crashed <- runHaddock cfg
+ checkFiles cfg crashed
-checkFiles :: Config c -> IO ()
-checkFiles cfg@(Config { .. }) = do
+checkFiles :: Config c -> Bool -> IO ()
+checkFiles cfg@(Config { .. }) somethingCrashed = do
putStrLn "Testing output files..."
files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
@@ -54,13 +54,14 @@ checkFiles cfg@(Config { .. }) = do
Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
Accepted -> putStrLn "ACCEPTED" >> return Nothing
- if null failed
- then do
- putStrLn "All tests passed!"
- exitSuccess
- else do
- maybeDiff cfg failed
- exitFailure
+ if (null failed && not somethingCrashed)
+ then do
+ putStrLn "All tests passed!"
+ exitSuccess
+ else do
+ unless (null failed) $ maybeDiff cfg failed
+ when somethingCrashed $ putStrLn "Some tests crashed."
+ exitFailure
where
ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
@@ -72,12 +73,14 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
forM_ files $ diffFile cfg diff
-runHaddock :: Config c -> IO ()
+-- | Runs Haddock on all of the test packages, and returns whether 'True' if
+-- any of them caused Haddock to crash.
+runHaddock :: Config c -> IO Bool
runHaddock cfg@(Config { .. }) = do
createEmptyDirectory $ cfgOutDir cfg
putStrLn "Generating documentation..."
- forM_ cfgPackages $ \tpkg -> do
+ successes <- forM cfgPackages $ \tpkg -> do
haddockStdOut <- openFile cfgHaddockStdOut WriteMode
let pc = processConfig
{ pcArgs = concat
@@ -87,9 +90,20 @@ runHaddock cfg@(Config { .. }) = do
]
, pcEnv = Just $ cfgEnv
, pcStdOut = Just $ haddockStdOut
+ , pcStdErr = Just $ haddockStdOut
}
- handle <- runProcess' cfgHaddockPath pc
- waitForSuccess "Failed to run Haddock on specified test files" handle
+
+ let msg = "Failed to run Haddock on test package '" ++ tpkgName tpkg ++ "'"
+ succeeded <- waitForSuccess msg stdout =<< runProcess' cfgHaddockPath pc
+ unless succeeded $ removeDirectoryRecursive (outDir cfgDirConfig tpkg)
+
+ pure succeeded
+
+ let somethingFailed = any not successes
+ when somethingFailed $
+ putStrLn ("Haddock output is at '" ++ cfgHaddockStdOut ++ "'. " ++
+ "This file can be set with `--haddock-stdout`.")
+ pure somethingFailed
checkFile :: Config c -> FilePath -> IO CheckResult
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 51032a3a..6447361f 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -196,6 +196,7 @@ loadConfig ccfg dcfg flags files = do
cfgHaddockArgs <- liftM concat . sequence $
[ pure ["--no-warnings"]
+ , pure ["--bypass-interface-version-check"]
, pure ["--odir=" ++ dcfgOutDir dcfg]
, pure ["--optghc=-w"]
, pure ["--optghc=-hide-all-packages"]
@@ -223,13 +224,13 @@ printVersions env haddockPath = do
{ pcEnv = Just env
, pcArgs = ["--version"]
}
- waitForSuccess "Failed to run `haddock --version`" handleHaddock
+ void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock
handleGhc <- runProcess' haddockPath $ processConfig
{ pcEnv = Just env
, pcArgs = ["--ghc-version"]
}
- waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+ void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc
baseDependencies :: FilePath -> IO [String]
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
index 52bf9533..a6cab9ac 100644
--- a/haddock-test/src/Test/Haddock/Process.hs
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -40,10 +40,10 @@ runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
runProcess' path (ProcessConfig { .. }) = runProcess
path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr
-
-waitForSuccess :: String -> ProcessHandle -> IO ()
-waitForSuccess msg handle = do
- result <- waitForProcess handle
- unless (result == ExitSuccess) $ do
- hPutStrLn stderr $ msg
- exitFailure
+-- | Wait for a process to finish running. If it ends up failing, print out the
+-- error message.
+waitForSuccess :: String -> Handle -> ProcessHandle -> IO Bool
+waitForSuccess msg out handle = do
+ succeeded <- fmap (== ExitSuccess) $ waitForProcess handle
+ unless succeeded $ hPutStrLn out msg
+ pure succeeded
diff --git a/haddock.cabal b/haddock.cabal
index 1c84562d..39d01c4d 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -78,7 +78,7 @@ executable haddock
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
ghc-boot,
- ghc == 8.6.*,
+ ghc == 8.7.*,
bytestring,
parsec,
text,
diff --git a/html-test/ref/TypeFamilies3.html b/html-test/ref/TypeFamilies3.html
new file mode 100644
index 00000000..2dadf435
--- /dev/null
+++ b/html-test/ref/TypeFamilies3.html
@@ -0,0 +1,356 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >TypeFamilies3</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >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"
+ >TypeFamilies3</p
+ ></div
+ ><div id="synopsis"
+ ><details id="syn"
+ ><summary
+ >Synopsis</summary
+ ><ul class="details-toggle" data-details-id="syn"
+ ><li class="src short"
+ ><span class="keyword"
+ >type family</span
+ > <a href="#"
+ >Foo</a
+ > a <span class="keyword"
+ >where ...</span
+ ></li
+ ><li class="src short"
+ ><span class="keyword"
+ >type family</span
+ > <a href="#"
+ >Bar</a
+ > a</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data family</span
+ > <a href="#"
+ >Baz</a
+ > a</li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >type family</span
+ > <a id="t:Foo" class="def"
+ >Foo</a
+ > a <span class="keyword"
+ >where ...</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A closed type family</p
+ ></div
+ ><div class="subs equations"
+ ><p class="caption"
+ >Equations</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a href="#" title="TypeFamilies3"
+ >Foo</a
+ > () = <a href="#" title="Data.Int"
+ >Int</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ ><a href="#" title="TypeFamilies3"
+ >Foo</a
+ > _ = ()</td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >type family</span
+ > <a id="t:Bar" class="def"
+ >Bar</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >An open family</p
+ ></div
+ ><div class="subs instances"
+ ><details id="i:Bar" open="open"
+ ><summary
+ >Instances</summary
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Bar:Bar:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies3"
+ >Bar</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ ></span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Bar:Bar:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies3</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies3"
+ >Bar</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > = ()</div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Bar:Bar:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies3"
+ >Bar</a
+ > ()</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Bar:Bar:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies3</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies3"
+ >Bar</a
+ > () = <a href="#" title="Data.Int"
+ >Int</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
+ ></details
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data family</span
+ > <a id="t:Baz" class="def"
+ >Baz</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A data family</p
+ ></div
+ ><div class="subs instances"
+ ><details id="i:Baz" open="open"
+ ><summary
+ >Instances</summary
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:1"
+ ></span
+ > <span class="keyword"
+ >newtype</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > <a href="#" title="Prelude"
+ >Double</a
+ ></span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Baz:Baz:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies3</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >newtype</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > <a href="#" title="Prelude"
+ >Double</a
+ > = <a id="v:Baz3" class="def"
+ >Baz3</a
+ > <a href="#" title="Prelude"
+ >Float</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:2"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ ></span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Baz:Baz:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies3</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > = <a id="v:Baz2" class="def"
+ >Baz2</a
+ > <a href="#" title="Data.Bool"
+ >Bool</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:3"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > ()</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Baz:Baz:3"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies3</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies3"
+ >Baz</a
+ > () = <a id="v:Baz1" class="def"
+ >Baz1</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
+ ></details
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ></div
+ ></body
+ ></html
+> \ No newline at end of file
diff --git a/html-test/ref/UnboxedStuff.html b/html-test/ref/UnboxedStuff.html
new file mode 100644
index 00000000..4c1196b9
--- /dev/null
+++ b/html-test/ref/UnboxedStuff.html
@@ -0,0 +1,196 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >UnboxedStuff</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >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"
+ >UnboxedStuff</p
+ ></div
+ ><div id="table-of-contents"
+ ><p class="caption"
+ >Contents</p
+ ><ul
+ ><li
+ ><a href="#"
+ >Unboxed type constructors</a
+ ></li
+ ></ul
+ ></div
+ ><div id="synopsis"
+ ><details id="syn"
+ ><summary
+ >Synopsis</summary
+ ><ul class="details-toggle" data-details-id="syn"
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >X</a
+ ></li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >Y</a
+ ></li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >Z</a
+ ></li
+ ><li class="src short"
+ ><a href="#"
+ >unboxedUnit</a
+ > :: (# #) -&gt; (# #)</li
+ ><li class="src short"
+ ><a href="#"
+ >unboxedTuple</a
+ > :: (# <a href="#" title="UnboxedStuff"
+ >X</a
+ >, <a href="#" title="UnboxedStuff"
+ >Y</a
+ > #) -&gt; (# <a href="#" title="UnboxedStuff"
+ >X</a
+ >, <a href="#" title="UnboxedStuff"
+ >Y</a
+ >, <a href="#" title="UnboxedStuff"
+ >Z</a
+ > #)</li
+ ><li class="src short"
+ ><a href="#"
+ >unboxedSum</a
+ > :: (# <a href="#" title="UnboxedStuff"
+ >X</a
+ > | <a href="#" title="UnboxedStuff"
+ >Y</a
+ > #) -&gt; (# <a href="#" title="UnboxedStuff"
+ >X</a
+ > | <a href="#" title="UnboxedStuff"
+ >Y</a
+ > | <a href="#" title="UnboxedStuff"
+ >Z</a
+ > #)</li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:X" class="def"
+ >X</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:Y" class="def"
+ >Y</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:Z" class="def"
+ >Z</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><a href="#" id="g:1"
+ ><h1
+ >Unboxed type constructors</h1
+ ></a
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:unboxedUnit" class="def"
+ >unboxedUnit</a
+ > :: (# #) -&gt; (# #) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:unboxedTuple" class="def"
+ >unboxedTuple</a
+ > :: (# <a href="#" title="UnboxedStuff"
+ >X</a
+ >, <a href="#" title="UnboxedStuff"
+ >Y</a
+ > #) -&gt; (# <a href="#" title="UnboxedStuff"
+ >X</a
+ >, <a href="#" title="UnboxedStuff"
+ >Y</a
+ >, <a href="#" title="UnboxedStuff"
+ >Z</a
+ > #) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:unboxedSum" class="def"
+ >unboxedSum</a
+ > :: (# <a href="#" title="UnboxedStuff"
+ >X</a
+ > | <a href="#" title="UnboxedStuff"
+ >Y</a
+ > #) -&gt; (# <a href="#" title="UnboxedStuff"
+ >X</a
+ > | <a href="#" title="UnboxedStuff"
+ >Y</a
+ > | <a href="#" title="UnboxedStuff"
+ >Z</a
+ > #) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ></div
+ ></body
+ ></html
+> \ No newline at end of file
diff --git a/html-test/src/TypeFamilies3.hs b/html-test/src/TypeFamilies3.hs
new file mode 100644
index 00000000..bde05fb8
--- /dev/null
+++ b/html-test/src/TypeFamilies3.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module TypeFamilies3 where
+
+-- | A closed type family
+type family Foo a where
+ Foo () = Int
+ Foo _ = ()
+
+-- | An open family
+type family Bar a
+
+type instance Bar Int = ()
+type instance Bar () = Int
+
+-- | A data family
+data family Baz a
+
+data instance Baz () = Baz1
+data instance Baz Int = Baz2 Bool
+newtype instance Baz Double = Baz3 Float
diff --git a/html-test/src/UnboxedStuff.hs b/html-test/src/UnboxedStuff.hs
new file mode 100644
index 00000000..bd1b1302
--- /dev/null
+++ b/html-test/src/UnboxedStuff.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples #-}
+module UnboxedStuff where
+
+data X
+data Y
+data Z
+
+-- * Unboxed type constructors
+
+unboxedUnit :: (# #) -> (# #)
+unboxedUnit = undefined
+
+unboxedTuple :: (# X, Y #) -> (# X, Y, Z #)
+unboxedTuple = undefined
+
+unboxedSum :: (# X | Y #) -> (# X | Y | Z #)
+unboxedSum = undefined
+
diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex
new file mode 100644
index 00000000..2a8ad297
--- /dev/null
+++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex
@@ -0,0 +1,44 @@
+\haddockmoduleheading{TypeFamilies3}
+\label{module:TypeFamilies3}
+\haddockbeginheader
+{\haddockverb\begin{verbatim}
+module TypeFamilies3 (
+ Foo, Bar, Baz(Baz3, Baz2, Baz1)
+ ) where\end{verbatim}}
+\haddockendheader
+
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+type\ family\ Foo\ a\ where
+\end{tabular}]\haddockbegindoc
+\haddockbeginargs
+\haddockdecltt{Foo () = Int} \\
+\haddockdecltt{Foo \_ = ()} \\
+\end{tabulary}\par
+A closed type family\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+type\ family\ Bar\ a
+\end{tabular}]\haddockbegindoc
+An open family\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+type\ instance\ Bar\ Int\ =\ ()\\type\ instance\ Bar\ ()\ =\ Int
+\end{tabular}]
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data\ family\ Baz\ a
+\end{tabular}]\haddockbegindoc
+A data family\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+newtype\ instance\ Baz\ Double\\data\ instance\ Baz\ Int\\data\ instance\ Baz\ ()
+\end{tabular}]
+\end{haddockdesc} \ No newline at end of file
diff --git a/latex-test/ref/TypeFamilies3/haddock.sty b/latex-test/ref/TypeFamilies3/haddock.sty
new file mode 100644
index 00000000..6e031a98
--- /dev/null
+++ b/latex-test/ref/TypeFamilies3/haddock.sty
@@ -0,0 +1,57 @@
+% Default Haddock style definitions. To use your own style, invoke
+% Haddock with the option --latex-style=mystyle.
+
+\usepackage{tabulary} % see below
+
+% make hyperlinks in the PDF, and add an expandabale index
+\usepackage[pdftex,bookmarks=true]{hyperref}
+
+\newenvironment{haddocktitle}
+ {\begin{center}\bgroup\large\bfseries}
+ {\egroup\end{center}}
+\newenvironment{haddockprologue}{\vspace{1in}}{}
+
+\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
+
+\newcommand{\haddockbeginheader}{\hrulefill}
+\newcommand{\haddockendheader}{\noindent\hrulefill}
+
+% a little gap before the ``Methods'' header
+\newcommand{\haddockpremethods}{\vspace{2ex}}
+
+% inserted before \\begin{verbatim}
+\newcommand{\haddockverb}{\small}
+
+% an identifier: add an index entry
+\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
+
+% The tabulary environment lets us have a column that takes up ``the
+% rest of the space''. Unfortunately it doesn't allow
+% the \end{tabulary} to be in the expansion of a macro, it must appear
+% literally in the document text, so Haddock inserts
+% the \end{tabulary} itself.
+\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+
+\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
+\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
+
+\makeatletter
+\newenvironment{haddockdesc}
+ {\list{}{\labelwidth\z@ \itemindent-\leftmargin
+ \let\makelabel\haddocklabel}}
+ {\endlist}
+\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
+\makeatother
+
+% after a declaration, start a new line for the documentation.
+% Otherwise, the documentation starts right after the declaration,
+% because we're using the list environment and the declaration is the
+% ``label''. I tried making this newline part of the label, but
+% couldn't get that to work reliably (the space seemed to stretch
+% sometimes).
+\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
+
+% spacing between paragraphs and no \parindent looks better
+\parskip=10pt plus2pt minus2pt
+\setlength{\parindent}{0cm}
diff --git a/latex-test/ref/TypeFamilies3/main.tex b/latex-test/ref/TypeFamilies3/main.tex
new file mode 100644
index 00000000..2c98043c
--- /dev/null
+++ b/latex-test/ref/TypeFamilies3/main.tex
@@ -0,0 +1,11 @@
+\documentclass{book}
+\usepackage{haddock}
+\begin{document}
+\begin{titlepage}
+\begin{haddocktitle}
+
+\end{haddocktitle}
+\end{titlepage}
+\tableofcontents
+\input{TypeFamilies3}
+\end{document} \ No newline at end of file
diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex
new file mode 100644
index 00000000..36d5c12b
--- /dev/null
+++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex
@@ -0,0 +1,36 @@
+\haddockmoduleheading{UnboxedStuff}
+\label{module:UnboxedStuff}
+\haddockbeginheader
+{\haddockverb\begin{verbatim}
+module UnboxedStuff (
+ X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum
+ ) where\end{verbatim}}
+\haddockendheader
+
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data\ X
+\end{tabular}]
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data\ Y
+\end{tabular}]
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data\ Z
+\end{tabular}]
+\end{haddockdesc}
+\section{Unboxed type constructors}
+\begin{haddockdesc}
+\item[
+unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43})
+]
+\item[
+unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43})
+]
+\item[
+unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43})
+]
+\end{haddockdesc} \ No newline at end of file
diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty
new file mode 100644
index 00000000..6e031a98
--- /dev/null
+++ b/latex-test/ref/UnboxedStuff/haddock.sty
@@ -0,0 +1,57 @@
+% Default Haddock style definitions. To use your own style, invoke
+% Haddock with the option --latex-style=mystyle.
+
+\usepackage{tabulary} % see below
+
+% make hyperlinks in the PDF, and add an expandabale index
+\usepackage[pdftex,bookmarks=true]{hyperref}
+
+\newenvironment{haddocktitle}
+ {\begin{center}\bgroup\large\bfseries}
+ {\egroup\end{center}}
+\newenvironment{haddockprologue}{\vspace{1in}}{}
+
+\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
+
+\newcommand{\haddockbeginheader}{\hrulefill}
+\newcommand{\haddockendheader}{\noindent\hrulefill}
+
+% a little gap before the ``Methods'' header
+\newcommand{\haddockpremethods}{\vspace{2ex}}
+
+% inserted before \\begin{verbatim}
+\newcommand{\haddockverb}{\small}
+
+% an identifier: add an index entry
+\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
+
+% The tabulary environment lets us have a column that takes up ``the
+% rest of the space''. Unfortunately it doesn't allow
+% the \end{tabulary} to be in the expansion of a macro, it must appear
+% literally in the document text, so Haddock inserts
+% the \end{tabulary} itself.
+\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+
+\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
+\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
+
+\makeatletter
+\newenvironment{haddockdesc}
+ {\list{}{\labelwidth\z@ \itemindent-\leftmargin
+ \let\makelabel\haddocklabel}}
+ {\endlist}
+\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
+\makeatother
+
+% after a declaration, start a new line for the documentation.
+% Otherwise, the documentation starts right after the declaration,
+% because we're using the list environment and the declaration is the
+% ``label''. I tried making this newline part of the label, but
+% couldn't get that to work reliably (the space seemed to stretch
+% sometimes).
+\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
+
+% spacing between paragraphs and no \parindent looks better
+\parskip=10pt plus2pt minus2pt
+\setlength{\parindent}{0cm}
diff --git a/latex-test/ref/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex
new file mode 100644
index 00000000..e34c5f14
--- /dev/null
+++ b/latex-test/ref/UnboxedStuff/main.tex
@@ -0,0 +1,11 @@
+\documentclass{book}
+\usepackage{haddock}
+\begin{document}
+\begin{titlepage}
+\begin{haddocktitle}
+
+\end{haddocktitle}
+\end{titlepage}
+\tableofcontents
+\input{UnboxedStuff}
+\end{document} \ No newline at end of file
diff --git a/latex-test/src/TypeFamilies3/TypeFamilies3.hs b/latex-test/src/TypeFamilies3/TypeFamilies3.hs
new file mode 100644
index 00000000..bde05fb8
--- /dev/null
+++ b/latex-test/src/TypeFamilies3/TypeFamilies3.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module TypeFamilies3 where
+
+-- | A closed type family
+type family Foo a where
+ Foo () = Int
+ Foo _ = ()
+
+-- | An open family
+type family Bar a
+
+type instance Bar Int = ()
+type instance Bar () = Int
+
+-- | A data family
+data family Baz a
+
+data instance Baz () = Baz1
+data instance Baz Int = Baz2 Bool
+newtype instance Baz Double = Baz3 Float
diff --git a/latex-test/src/UnboxedStuff/UnboxedStuff.hs b/latex-test/src/UnboxedStuff/UnboxedStuff.hs
new file mode 100644
index 00000000..bd1b1302
--- /dev/null
+++ b/latex-test/src/UnboxedStuff/UnboxedStuff.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples #-}
+module UnboxedStuff where
+
+data X
+data Y
+data Z
+
+-- * Unboxed type constructors
+
+unboxedUnit :: (# #) -> (# #)
+unboxedUnit = undefined
+
+unboxedTuple :: (# X, Y #) -> (# X, Y, Z #)
+unboxedTuple = undefined
+
+unboxedSum :: (# X | Y #) -> (# X | Y | Z #)
+unboxedSum = undefined
+