diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 15 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 53 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 67 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 |
4 files changed, 64 insertions, 73 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f581c01a..149f4815 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -263,13 +263,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ n) = HsTyVar NoExt NotPromoted n - tyVarArg (KindedTyVar _ n lty) = HsKindSig NoExt (reL (HsTyVar NoExt NotPromoted n)) lty - tyVarArg _ = panic "ppCtor" - - resType = apps $ map reL $ - (HsTyVar NoExt NotPromoted (reL (tcdName dat))) : - map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map noLoc (c : as)) + + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 85769b13..119bbc01 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -461,7 +461,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) --- This splits up a type signature along `->` and adds docs (when they exist) +-- | This splits up a type signature along @->@ and adds docs (when they exist) -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode @@ -477,13 +477,10 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ tvs ltype) - = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - ) ] + do_args n leader (HsForAllTy _ tvs ltype) + = do_largs n (leader <+> decltt (ppForAllPart unicode tvs)) ltype do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) + = (decltt leader, decltt (ppLContextNoArrow lctxt unicode) <+> nl) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) @@ -515,8 +512,9 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) +-- | Pretty-print type variables. +ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -719,15 +717,21 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty + ppForall + | null tvs || not forall_ = empty + | otherwise = ppForAllPart unicode tvs + + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space -- | Pretty-print a constructor @@ -756,11 +760,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- First line of the constructor (no doc, no fields, single-line) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' @@ -1023,13 +1026,17 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX +ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot + + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX ppr_mono_ty (HsForAllTy _ tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + = sep [ ppForAllPart unicode tvs , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode @@ -1043,7 +1050,7 @@ ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 9952721c..f2cab635 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -133,8 +133,8 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) curname = getName <$> listToMaybe docnames --- This splits up a type signature along `->` and adds docs (when they exist) to --- the arguments. +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. -- -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. @@ -152,9 +152,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual + = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -188,15 +186,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ gadtOpen = toHtml "{" - -ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ dot - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge @@ -261,10 +250,6 @@ ppTypeSig summary nms pp_ty unicode = htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocNameI -> Html @@ -821,24 +806,23 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualificati ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ +++ ppOcc <+> char '{' + ( header_ <+> ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -847,7 +831,7 @@ ppShortConstrParts summary dataInst con unicode qual -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 ] @@ -895,28 +879,27 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon args - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppOcc + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' - RecCon _ -> header_ +++ ppOcc <+> fixity + RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 , fixity @@ -969,17 +952,17 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -- ^ print explicit foralls - -> [Name] -- ^ type variables - -> HsContext DocNameI -- ^ context - -> Unicode -> Qualification -> Html +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification + -> Html ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = forallSymbol unicode - <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " + | otherwise = ppForAllPart unicode qual tvs ppCtxt | null ctxt = noHtml @@ -1186,7 +1169,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u q _ = ppr_mono_ty (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsKindSig _ ty kind) u q e = - parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) + ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 10d6ab10..b1d64acd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -58,7 +58,7 @@ standardTheme :: FilePath -> IO PossibleThemes standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. |