aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haddock-api/src/Haddock.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs131
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs222
-rw-r--r--haddock-api/src/Haddock/Convert.hs10
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs2
-rw-r--r--haddock-api/src/Haddock/Options.hs2
-rw-r--r--haddock-test/src/Test/Haddock.hs44
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs4
-rw-r--r--haddock-test/src/Test/Haddock/Process.hs14
-rw-r--r--html-test/ref/TypeFamilies3.html356
-rw-r--r--html-test/src/TypeFamilies3.hs21
-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/src/TypeFamilies3/TypeFamilies3.hs21
15 files changed, 769 insertions, 176 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 40da7ceb..d294b612 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -75,6 +75,7 @@ import Packages
import Panic (handleGhcException)
import Module
import FastString
+import qualified DynamicLoading
--------------------------------------------------------------------------------
-- * Exception handling
@@ -448,7 +449,10 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
-- that may need to be re-linked: Haddock doesn't do any
-- dynamic or static linking at all!
_ <- setSessionDynFlags dynflags''
- ghcActs dynflags''
+ hscenv <- GHC.getSession
+ dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'')
+ _ <- setSessionDynFlags dynflags'''
+ ghcActs dynflags'''
where
-- ignore sublists of flags that start with "+RTS" and end in "-RTS"
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4a3e9d03..4e0e6eba 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
@@ -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)
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/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6eee353b..044e1e11 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 )
+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
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/Options.hs b/haddock-api/src/Haddock/Options.hs
index e89fcbde..46db572b 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -189,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 68f6b867..6447361f 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -224,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/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/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/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/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