aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs108
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs33
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs75
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs341
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs4
8 files changed, 308 insertions, 274 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 02430deb..56f8176c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,10 +18,12 @@ module Haddock.Backends.Hoogle (
import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
import InstEnv (ClsInst(..))
+import Documentation.Haddock.Markup
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
+import HsBinds (emptyLHsBinds)
import GHC
import Outputable
import NameSet
@@ -157,7 +159,9 @@ pp_sig dflags names (L _ typ) =
-- note: does not yet output documentation for class methods
ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods
+ppClass dflags decl subdocs =
+ (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}
+ ++ ppTyFams) : ppMethods
where
ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 1b39e5e8..759a31d4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,21 +1,29 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
-
+{-# LANGUAGE TypeApplications #-}
module Haddock.Backends.Hyperlinker.Ast (enrich) where
-import Haddock.Syb
+import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
import Control.Applicative
+import Control.Monad (guard)
import Data.Data
+import qualified Data.Map.Strict as Map
import Data.Maybe
+import Prelude hiding (span)
+
+everythingInRenamedSource :: (Alternative f, Data x)
+ => (forall a. Data a => a -> f r) -> x -> f r
+everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f
-- | Add more detailed information to token stream using GHC API.
enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
@@ -25,25 +33,45 @@ enrich src =
, rtkDetails = enrichToken token detailsMap
}
where
- detailsMap = concatMap ($ src)
- [ variables
- , types
- , decls
- , binds
- , imports
- ]
+ detailsMap =
+ mkDetailsMap (concatMap ($ src)
+ [ variables
+ , types
+ , decls
+ , binds
+ , imports
+ ])
+
+type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]
-- | A map containing association between source locations and "details" of
-- this location.
--
--- For the time being, it is just a list of pairs. However, looking up things
--- in such structure has linear complexity. We cannot use any hashmap-like
--- stuff because source locations are not ordered. In the future, this should
--- be replaced with interval tree data structure.
-type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
+type DetailsMap = Map.Map Position (Span, TokenDetails)
+
+mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
+mkDetailsMap xs =
+ Map.fromListWith select_details [ (start, (token_span, token_details))
+ | (ghc_span, token_details) <- xs
+ , Just !token_span <- [ghcSrcSpanToSpan ghc_span]
+ , let start = spStart token_span
+ ]
+ where
+ -- favour token details which appear earlier in the list
+ select_details _new old = old
lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+lookupBySpan span details = do
+ (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
+ guard (tok_span `containsSpan` span )
+ return tok_details
+
+ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
+ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
+ Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
+ , spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
+ })
+ghcSrcSpanToSpan _ = Nothing
enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
enrichToken (Token typ _ spn) dm
@@ -51,9 +79,9 @@ enrichToken (Token typ _ spn) dm
enrichToken _ _ = Nothing
-- | Obtain details map for variables ("normally" used identifiers).
-variables :: GHC.RenamedSource -> DetailsMap
+variables :: GHC.RenamedSource -> LTokenDetails
variables =
- everything (<|>) (var `combine` rec)
+ everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
(Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
@@ -67,9 +95,8 @@ variables =
_ -> empty
-- | Obtain details map for types.
-types :: GHC.RenamedSource -> DetailsMap
-types =
- everything (<|>) ty
+types :: GHC.RenamedSource -> LTokenDetails
+types = everythingInRenamedSource ty
where
ty term = case cast term of
(Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
@@ -81,9 +108,10 @@ types =
-- That includes both identifiers bound by pattern matching or declared using
-- ordinary assignment (in top-level declarations, let-expressions and where
-- clauses).
-binds :: GHC.RenamedSource -> DetailsMap
-binds =
- everything (<|>) (fun `combine` pat `combine` tvar)
+
+binds :: GHC.RenamedSource -> LTokenDetails
+binds = everythingInRenamedSource
+ (fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
(Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
@@ -93,7 +121,7 @@ binds =
(Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
- [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+ [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
(Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -109,11 +137,11 @@ binds =
_ -> empty
-- | Obtain details map for top-level declarations.
-decls :: GHC.RenamedSource -> DetailsMap
+decls :: GHC.RenamedSource -> LTokenDetails
decls (group, _, _, _) = concatMap ($ group)
[ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
- , everything (<|>) fun . GHC.hs_valds
- , everything (<|>) (con `combine` ins)
+ , everythingInRenamedSource fun . GHC.hs_valds
+ , everythingInRenamedSource (con `Syb.combine` ins)
]
where
typ (GHC.L _ t) = case t of
@@ -127,7 +155,8 @@ decls (group, _, _, _) = concatMap ($ group)
_ -> empty
con term = case cast term of
(Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
- map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl
+ map decl (GHC.getConNames cdcl)
+ ++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
(Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn))
@@ -148,9 +177,9 @@ decls (group, _, _, _) = concatMap ($ group)
--
-- This map also includes type and variable details for items in export and
-- import lists.
-imports :: GHC.RenamedSource -> DetailsMap
+imports :: GHC.RenamedSource -> LTokenDetails
imports src@(_, imps, _, _) =
- everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
+ everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
(Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
@@ -165,22 +194,3 @@ imports src@(_, imps, _, _) =
let (GHC.L sspan name) = GHC.ideclName idecl
in Just (sspan, RtkModule name)
imp _ = Nothing
-
--- | Check whether token stream span matches GHC source span.
---
--- Currently, it is implemented as checking whether "our" span is contained
--- in GHC span. The reason for that is because GHC span are generally wider
--- and may spread across couple tokens. For example, @(>>=)@ consists of three
--- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable
--- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@
--- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span
--- associated with @quux@ contains all five elements.
-matches :: Span -> GHC.SrcSpan -> Bool
-matches tspan (GHC.RealSrcSpan aspan)
- | saspan <= stspan && etspan <= easpan = True
- where
- stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)
- etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)
- saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
- easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
-matches _ _ = False
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index b27ec4d8..d8ae89e4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -10,7 +10,7 @@ import qualified Data.Map as Map
data Token = Token
{ tkType :: TokenType
, tkValue :: String
- , tkSpan :: Span
+ , tkSpan :: {-# UNPACK #-} !Span
}
deriving (Show)
@@ -18,14 +18,20 @@ data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
- deriving (Show)
+ deriving (Eq, Ord, Show)
data Span = Span
- { spStart :: Position
- , spEnd :: Position
+ { spStart :: !Position
+ , spEnd :: !Position
}
deriving (Show)
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True where spans are equal.
+containsSpan :: Span -> Span -> Bool
+containsSpan s1 s2 =
+ spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2
+
data TokenType
= TkIdentifier
| TkKeyword
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 8ca9075b..d4a3012e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -16,6 +16,7 @@ module Haddock.Backends.LaTeX (
) where
+import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
@@ -227,8 +228,8 @@ isExportModule _ = Nothing
processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
- = ppDecl decl doc insts subdocs fixities
+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+ = ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
processExport (ExportNoDecl y subs)
@@ -278,16 +279,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
ppDecl :: LHsDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
-> DocForDecl DocName
-> [DocInstance DocNameI]
-> [(DocName, DocForDecl DocName)]
-> [(DocName, Fixity)]
-> LaTeX
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc (Just doc) d unicode
+ -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
@@ -565,11 +567,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-------------------------------------------------------------------------------
-ppDataDecl :: [DocInstance DocNameI] ->
+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->
[(DocName, DocForDecl DocName)] -> SrcSpan ->
Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
+ppDataDecl pats instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
@@ -579,10 +581,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+ body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
- | null cons = (empty,[])
+ | null cons
+ , null pats = (empty,[])
+ | null cons = (decltt (keyword "where"), repeat empty)
| otherwise = case resTy of
ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
@@ -594,6 +598,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
text "\\end{tabulary}\\par"
+ patternBit
+ | null cons = Nothing
+ | otherwise = Just $
+ text "\\haddockbeginconstrs" $$
+ vcat [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
+ , dcolon unicode
+ , ppLType unicode (hsSigType ty)
+ ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
+ | (SigD (PatSynSig lnames ty),d) <- pats
+ ] $$
+ text "\\end{tabulary}\\par"
+
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4a3562ae..7fbf9bb4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -109,8 +109,8 @@ copyHtmlBits odir libdir themes = do
return ()
-headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html
-headHtml docTitle miniPage themes mathjax_url =
+headHtml :: String -> Themes -> Maybe String -> Html
+headHtml docTitle themes mathjax_url =
header << [
meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
thetitle << docTitle,
@@ -119,15 +119,12 @@ headHtml docTitle miniPage themes mathjax_url =
script ! [src mjUrl, thetype "text/javascript"] << noHtml,
script ! [thetype "text/javascript"]
-- NB: Within XHTML, the content of script tags needs to be
- -- a <![CDATA[ section. Will break if the miniPage name could
- -- have "]]>" in it!
- << primHtml (
- "//<![CDATA[\nwindow.onload = function () {pageLoad();"
- ++ setSynopsis ++ "};\n//]]>\n")
+ -- a <![CDATA[ section.
+ << primHtml
+ "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n"
]
where
- setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
- mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
+ mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
@@ -272,7 +269,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
| iface <- ifaces
, instIsSig iface]
html =
- headHtml doctitle Nothing themes mathjax_url +++
+ headHtml doctitle themes mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
@@ -373,7 +370,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
where
indexPage showLetters ch items =
- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++
+ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
maybe_contents_url Nothing << [
@@ -495,7 +492,7 @@ ppHtmlModule odir doctitle themes
= toHtml mdl_str
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+ headHtml mdl_str_annot themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
@@ -505,23 +502,10 @@ ppHtmlModule odir doctitle themes
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
-ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
- let mdl = ifaceMod iface
- html =
- headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++
- miniBody <<
- (divModuleHeader << sectionName << moduleString mdl +++
- miniSynopsis mdl iface unicode qual)
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
-
ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
@@ -573,43 +557,6 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
linksInfo = (maybe_source_url, maybe_wiki_url)
-miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
-miniSynopsis mdl iface unicode qual =
- divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
- where
- exports = numberSectionHeadings (ifaceRnExportItems iface)
-
-
-processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocNameI
- -> [Html]
-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
- ((divTopDecl <<).(declElem <<)) <$> case decl0 of
- TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
- (DataDecl{}) -> [keyword "data" <+> b]
- (SynDecl{}) -> [keyword "type" <+> b]
- (ClassDecl {}) -> [keyword "class" <+> b]
- SigD (TypeSig lnames _) ->
- map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
- _ -> []
-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
- [groupTag lvl << docToHtml Nothing qual (mkMeta txt)]
-processForMiniSynopsis _ _ _ _ = []
-
-
-ppNameMini :: Notation -> Module -> OccName -> Html
-ppNameMini notation mdl nm =
- anchor ! [ href (moduleNameUrl mdl nm)
- , target mainFrameName ]
- << ppBinder' notation nm
-
-
-ppTyClBinderWithVarsMini :: Module -> TyClDecl DocNameI -> Html
-ppTyClBinderWithVarsMini mdl decl =
- let n = tcdName decl
- ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
- in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
-
ppModuleContents :: Qualification
-> [ExportItem DocNameI]
-> Bool -- ^ Orphans sections
@@ -659,8 +606,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 2d9d7392..59ad41e4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,11 +41,12 @@ import BooleanFormula
import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
- -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
+ -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
@@ -70,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
Splice -> Unicode -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
- splice unicode qual
+ splice unicode qual HideEmptyContexts
where
- pp_typ = ppLType unicode qual typ
+ pp_typ = ppLType unicode qual HideEmptyContexts typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsSigType DocNameI ->
@@ -86,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode
pref1 = hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
, dcolon unicode
- , ppLType unicode qual (hsSigType typ)
+ , ppPatSigType unicode qual (hsSigType typ)
]
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
- Splice -> Unicode -> Qualification -> Html
+ Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
- splice unicode qual =
+ splice unicode qual emptyCtxts =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
, addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
- splice unicode qual
+ splice unicode qual emptyCtxts
where
occnames = map (nameOccName . getName) docnames
addFixities html
@@ -109,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
- -> Splice -> Unicode -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
+ -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
| summary = pref1
| Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
| otherwise = topDeclElem links loc splice docnames pref2 +++
@@ -131,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
| null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
- = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+ = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy lt r)
- = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+ = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = [(leader <+> ppType unicode qual t, argDoc n, [])]
+ = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
@@ -171,8 +172,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
-- | Pretty-print type variables.
-ppTyVars :: [LHsTyVarBndr DocNameI] -> [Html]
-ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
+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
@@ -196,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
splice unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
- splice unicode qual
+ splice unicode qual ShowEmptyToplevelContexts
where
hdr = hsep ([keyword "type", ppBinder summary occ]
- ++ ppTyVars (hsQTvExplicit ltyvars))
- full = hdr <+> equals <+> ppLType unicode qual ltype
+ ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
+ full = hdr <+> equals <+> ppPatSigType unicode qual ltype
occ = nameOccName . getName $ name
fixs
| summary = noHtml
@@ -219,14 +220,14 @@ ppTyName :: Name -> Html
ppTyName = ppName Prefix
-ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-> [DocName] -> HsType DocNameI
-> Html
-ppSimpleSig links splice unicode qual loc names typ =
+ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
where
topDeclElem' = topDeclElem links loc splice
- ppTyp = ppType unicode qual typ
+ ppTyp = ppType unicode qual emptyCtxts typ
occNames = map getOccName names
@@ -320,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
, tfe_pats = HsIB { hsib_body = ts }}
= ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
- <+> equals <+> ppType unicode qual (unLoc rhs)
+ <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
@@ -353,20 +354,20 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
-- | 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) (map unLoc $ hsq_explicit tvs)
+ ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
-- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> TyClDecl DocNameI -> Html
-ppDataBinderWithVars summ decl =
- ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
+ppDataBinderWithVars summ unicode qual decl =
+ ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
-ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocNameI] -> Html
+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
- ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)
+ ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
where
ppDN notation = ppBinderFixity notation summ . nameOccName . getName
ppBinderFixity Infix = ppBinderInfix
@@ -376,18 +377,9 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs =
ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI]
-> Unicode -> Qualification -> Html
ppAppNameTypes n ks ts unicode qual =
- ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
+ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
--- | Print an application of a 'DocName' and a list of 'Names'
-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
-ppAppDocNameNames summ n ns =
- ppTypeApp n [] ns ppDN ppTyName
- where
- ppDN notation = ppBinderFixity notation summ . nameOccName . getName
- ppBinderFixity Infix = ppBinderInfix
- ppBinderFixity _ = ppBinder
-
-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
ppTypeApp n [] (t1:t2:rest) ppDN ppT
@@ -406,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
- -> Qualification -> Html
+ -> Qualification -> HideEmptyContexts -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> Html
-ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
- ppContextNoLocsMaybe (map unLoc cxt) unicode qual
+ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
+ ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
-ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> Html
-ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $
- ppContextNoLocsMaybe cxt unicode qual
+ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $
+ ppContextNoLocsMaybe cxt unicode qual emptyCtxts
-ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> Maybe Html
-ppContextNoLocsMaybe [] _ _ = Nothing
-ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual
+ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
+ppContextNoLocsMaybe [] _ _ emptyCtxts =
+ case emptyCtxts of
+ HideEmptyContexts -> Nothing
+ ShowEmptyToplevelContexts -> Just (toHtml "()")
+ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
-ppContext :: HsContext DocNameI -> Unicode -> Qualification -> Html
-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts
-ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification-> Html
-ppHsContext [] _ _ = noHtml
+ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html
+ppHsContext [] _ _ = noHtml
ppHsContext [p] unicode qual = ppCtxType unicode qual p
-ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)
-------------------------------------------------------------------------------
@@ -444,8 +439,8 @@ ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
- <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
+ <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
<+> ppFds fds unicode qual
@@ -529,9 +524,8 @@ ppClassDecl summary links instances fixities loc d subdocs
, f@(n',_) <- fixities
, n == n' ]
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?
+ -- N.B. taking just the first name is ok. Signatures with multiple names
+ -- are expanded so that each name gets its own signature.
minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
@@ -601,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
case ihdInstType of
ClassInst { .. } ->
- ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
+ ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
, mdoc
, [subInstDetails iid ats sigs]
)
@@ -616,14 +610,14 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
where
ptype = keyword "type" <+> typ
prhs = ptype <+> maybe noHtml
- (\t -> equals <+> ppType unicode qual t) rhs
+ (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs
DataInst dd ->
( subInstHead iid pdata
, mdoc
, [subFamInstDetails iid pdecl])
where
pdata = keyword "data" <+> typ
- pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
+ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -644,8 +638,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstanceSigs links splice unicode qual sigs = do
TypeSig lnames typ <- sigs
let names = map unLoc lnames
- L loc rtyp = hsSigWcType typ
- return $ ppSimpleSig links splice unicode qual loc names rtyp
+ L _ rtyp = hsSigWcType typ
+ -- Instance methods signatures are synified and thus don't have a useful
+ -- SrcSpan value. Use the methods name location instead.
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -672,20 +668,23 @@ instanceId origin no orphan ihd = concat $
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
+ -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl pats unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons
+ , [] <- pats = dataHeader
- | [lcon] <- cons, isH98,
+ | [lcon] <- cons, [] <- pats, isH98,
(cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
- | isH98 = dataHeader
- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+ | [] <- pats, isH98 = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)
| otherwise = (dataHeader <+> keyword "where")
- +++ shortSubDecls dataInst (map doGADTConstr cons)
+ +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)
where
dataHeader
@@ -699,16 +698,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ pats1 = [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppPatSigType unicode qual (hsSigType typ)
+ ]
+ | (SigD (PatSynSig lnames typ),_) <- pats
+ ]
+
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
+ [(HsDecl DocNameI, DocForDecl DocName)] ->
Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode qual
- | summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary False dataDecl pats unicode qual
+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -723,7 +731,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
whereBit
- | null cons = noHtml
+ | null cons
+ , null pats = noHtml
+ | null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
constrBit = subConstructors qual
@@ -733,6 +743,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (getConNames (unLoc c)))) fixities
]
+ patternBit = subPatterns qual
+ [ (hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppPatSigType unicode qual (hsSigType typ)
+ ] <+> ppFixities subfixs qual
+ ,combineDocumentation (fst d), [])
+ | (SigD (PatSynSig lnames typ),d) <- pats
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+ ]
+
instancesBit = ppInstances links (OriginData docname) instances
splice unicode qual
@@ -751,17 +772,17 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
ConDeclH98{} -> case con_details con of
PrefixCon args ->
(header_ unicode qual +++ hsep (ppOcc
- : map (ppLParendType unicode qual) args), noHtml, noHtml)
+ : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
RecCon (L _ fields) ->
(header_ unicode qual +++ ppOcc <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
- (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppOccInfix, ppLParendType unicode qual arg2],
+ (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
+ ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
noHtml, noHtml)
- ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)
+ ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
where
resTy = hsib_body (con_type con)
@@ -793,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
(if null ctxt then noHtml
- else ppContextNoArrow ctxt unicode qual
+ else ppContextNoArrow ctxt unicode qual HideEmptyContexts
<+> darrow unicode +++ toHtml " ")
where
ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
@@ -809,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ConDeclH98{} -> case con_details con of
PrefixCon args ->
hsep ((header_ +++ ppOcc)
- : map (ppLParendType unicode qual) args)
+ : map (ppLParendType unicode qual HideEmptyContexts) args)
<+> fixity
RecCon _ -> header_ +++ ppOcc <+> fixity
InfixCon arg1 arg2 ->
- hsep [header_ +++ ppLParendType unicode qual arg1,
+ hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
ppOccInfix,
- ppLParendType unicode qual arg2]
+ ppLParendType unicode qual HideEmptyContexts arg2]
<+> fixity
ConDeclGADT{} -> doGADTCon resTy
@@ -834,7 +855,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
doGADTCon :: Located (HsType DocNameI) -> Html
doGADTCon ty = ppOcc <+> dcolon unicode
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
- <+> ppLType unicode qual ty
+ <+> ppLType unicode qual HideEmptyContexts ty
<+> fixity
fixity = ppFixities fixities qual
@@ -861,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocNameI -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
- (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
- mbDoc,
- [])
+ ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ <+> dcolon unicode
+ <+> ppLType unicode qual HideEmptyContexts ltype
+ , mbDoc
+ , []
+ )
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
@@ -873,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
- <+> dcolon unicode <+> ppLType unicode qual ltype
+ <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
-- | Print the LHS of a data\/newtype declaration.
@@ -888,9 +912,9 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
<+>
-- context
- ppLContext ctxt unicode qual <+>
+ ppLContext ctxt unicode qual HideEmptyContexts <+>
-- T a b c ..., or a :+: b
- ppDataBinderWithVars summary decl
+ ppDataBinderWithVars summary unicode qual decl
<+> case ks of
Nothing -> mempty
Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
@@ -940,19 +964,18 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
- -> Located (HsType DocNameI) -> Html
-ppLType unicode qual y = ppType unicode qual (unLoc y)
-ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
-ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
+ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
+ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
+ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
+ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts
-ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
- -> HsType DocNameI -> Html
-ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
-ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
-ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
-ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html
+ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
+ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _ qual (UserTyVar (L _ name)) =
@@ -965,62 +988,85 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-
-ppForAllPart :: [LHsTyVarBndr DocNameI] -> Unicode -> Html
-ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-
-ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
+
+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType unicode qual typ =
+ let emptyCtxts =
+ if hasNonEmptyContext typ && isFirstContextEmpty typ
+ then ShowEmptyToplevelContexts
+ else HideEmptyContexts
+ in ppLType unicode qual emptyCtxts typ
+ where
+ hasNonEmptyContext :: LHsType name -> Bool
+ hasNonEmptyContext t =
+ case unLoc t of
+ HsForAllTy _ s -> hasNonEmptyContext s
+ HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ s -> hasNonEmptyContext s
+ _ -> False
+ isFirstContextEmpty :: LHsType name -> Bool
+ isFirstContextEmpty t =
+ case unLoc t of
+ HsForAllTy _ s -> isFirstContextEmpty s
+ HsQualTy cxt _ -> null (unLoc cxt)
+ HsFunTy _ s -> isFirstContextEmpty s
+ _ -> False
+
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
+ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
+
+ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual
+ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
- ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual
+ ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
- ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
+ ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _
+ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
-ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
-ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u q =
- parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q =
- maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
-ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
+ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+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 pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+ maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
+ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
-ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy"
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
= maybeParen ctxt_prec pREC_CTX $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
= maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
= maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
where
-- `(:)` is valid in type signature only as constructor to promoted list
-- and needs to be quoted in code so we explicitly quote it here too.
@@ -1029,25 +1075,24 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
-- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode qual
+ = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
- = ppr_mono_lty ctxt_prec ty unicode qual
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+ = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
-ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
- p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
in
maybeParen ctxt_prec pREC_FUN $
hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e36f9528..18c8a0ff 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -20,6 +20,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
) where
import Data.List
+import Documentation.Haddock.Markup
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 41457f72..6993c7f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subPatterns,
subEquations,
subFields,
subInstances, subOrphanInstances,
@@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
subConstructors :: Qualification -> [SubDecl] -> Html
subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subPatterns :: Qualification -> [SubDecl] -> Html
+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+
subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 21:21:27 +0000