diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.21.0 +version: 2.22.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -48,6 +48,7 @@ import Data.Maybe import Data.IORef import Data.Map (Map) +import Data.Version (makeVersion) import qualified Data.Map as Map import System.IO import System.Exit @@ -363,9 +364,13 @@ -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do case pkgNameVer of - (Just (PackageName pkgNameFS), Just pkgVer) -> - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title - | otherwise = unpackFS pkgNameFS + (Just (PackageName pkgNameFS), mpkgVer) -> + let + pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + + pkgVer = + fromMaybe (makeVersion []) mpkgVer in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -122,10 +122,14 @@ ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl - , expItemMbDoc = (dc, _) + , expItemPats = bundledPats + , expItemMbDoc = mbDoc , expItemSubDocs = subdocs , expItemFixities = fixities - } = ppDocumentation dflags dc ++ f decl ++ ppFixities + } = concat [ ppDocumentation dflags dc ++ f d + | (d, (dc, _)) <- (decl, mbDoc) : bundledPats + ] ++ + ppFixities where f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs f (TyClD _ d@SynDecl{}) = ppSynonym dflags d @@ -140,12 +144,13 @@ ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig _ names sig) subdocs - = concatMap mkDocSig names - where - mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)] - -ppSigWithDoc _ _ _ = [] +ppSigWithDoc dflags sig subdocs = case sig of + TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names + _ -> [] + where + mkDocSig leader typ n = mkSubdoc dflags n subdocs + [leader ++ pp_sig dflags [n] typ] ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/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 @@ -> 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 @@ 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 @@ ------------------------------------------------------------------------------- +-- * 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 @@ | 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 @@ 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 @@ 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,7 +894,13 @@ -- * 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 ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) @@ -917,6 +994,12 @@ 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 (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/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/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 @@ -> 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 @@ 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,10 +220,7 @@ 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)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html @@ -283,113 +278,113 @@ -------------------------------------------------------------------------------- -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" +-- | 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 + ] -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 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" + + -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -399,25 +394,10 @@ -> [(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 @@ , 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 @@ -> [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 @@ -- | 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 @@ -- 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 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/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -84,6 +84,7 @@ processModules verbosity modules flags extIfaces = do #if defined(mingw32_HOST_OS) -- Avoid internal error: : hPutChar: invalid argument (invalid character)' non UTF-8 Windows + liftIO $ hSetEncoding stdout $ mkLocaleEncoding TransliterateCodingFailure liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure #endif