aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2021-01-05 16:23:02 -0500
committerBen Gamari <ben@smart-cactus.org>2021-01-05 16:23:02 -0500
commit99f61534a470b84c424fde0835215de6a3b6d721 (patch)
tree7152e5a53fe1c18e6fd5044d5aa3168ab99c3cc6 /haddock-api/src/Haddock/Backends
parent3e29ec51498dfe092b228889343dc8370ec0e64b (diff)
parent1e56f63c3197e7ca1c1e506e083c2bad25d08793 (diff)
Merge commit '1e56f63c3197e7ca1c1e506e083c2bad25d08793' into ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs17
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs44
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs289
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs166
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs20
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs28
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs2
11 files changed, 335 insertions, 258 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index c5a0f772..c114e84d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Hoogle
@@ -37,8 +38,6 @@ import Data.Version
import System.Directory
import System.FilePath
-import GHC.Core.Multiplicity
-
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
,"-- See Hoogle, http://www.haskell.org/hoogle/"
@@ -85,7 +84,7 @@ dropHsDocTy = f
f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
f (HsParTy x a) = HsParTy x (g a)
f (HsKindSig x a b) = HsKindSig x (g a) b
- f (HsDocTy _ a _) = f $ unL a
+ f (HsDocTy _ a _) = f $ unLoc a
f x = x
outHsType :: (OutputableBndrId p)
@@ -217,7 +216,7 @@ ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
= showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
- concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
+ concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
where
-- GHC gives out "data Bar =", we want to delete the equals.
@@ -253,7 +252,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- We print the constructors as comma-separated list. See GHC
-- docs for con_names on why it is a list to begin with.
- name = commaSeparate dflags . map unL $ getConNames con
+ name = commaSeparate dflags . map unLoc $ getConNames con
tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
@@ -268,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
where
f = [typeSig name (getGADTConTypeG con)]
- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
- name = out dflags $ map unL $ getConNames con
+ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)
+ name = out dflags $ map unLoc $ getConNames con
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
@@ -298,7 +297,7 @@ docWith dflags header d
mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
where
- getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
+ getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
deriving Show
@@ -325,7 +324,7 @@ markupTag dflags = Markup {
markupString = str,
markupAppend = (++),
markupIdentifier = box (TagInline "a") . str . out dflags,
- markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
+ markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),
markupModule = box (TagInline "a") . str,
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index d315ced0..6ef07434 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -7,7 +7,7 @@ module Haddock.Backends.Hyperlinker
import Haddock.Types
-import Haddock.Utils (writeUtf8File)
+import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)
import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types
@@ -18,8 +18,9 @@ import Data.Maybe
import System.Directory
import System.FilePath
-import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..) )
+import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..), SourcedNodeInfo(..) )
import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
+import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc )
import Data.Map as M
import GHC.Data.FastString ( mkFastString )
import GHC.Unit.Module ( Module, moduleName )
@@ -32,27 +33,28 @@ import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
-- Note that list of interfaces should also contain interfaces normally hidden
-- when generating documentation. Otherwise this could lead to dead links in
-- produced source.
-ppHyperlinkedSource :: FilePath -- ^ Output directory
+ppHyperlinkedSource :: Verbosity
+ -> FilePath -- ^ Output directory
-> FilePath -- ^ Resource directory
-> Maybe FilePath -- ^ Custom CSS file path
-> Bool -- ^ Flag indicating whether to pretty-print HTML
-> M.Map Module SrcPath -- ^ Paths to sources
-> [Interface] -- ^ Interfaces for which we create source
-> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do
+ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do
createDirectoryIfMissing True srcdir
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
+ mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces
where
srcdir = outdir </> hypSrcDir
srcs = (srcs', M.mapKeys moduleName srcs')
-- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO ()
-ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
+ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
+ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of
Just hfp -> do
-- Parse the GHC-produced HIE file
u <- mkSplitUniqSupply 'a'
@@ -66,25 +68,33 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
<$> (readHieFile ncu hfp)
-- Get the AST and tokens corresponding to the source file we want
- let mast | M.size asts == 1 = snd <$> M.lookupMin asts
- | otherwise = M.lookup (mkFastString file) asts
+ let fileFs = mkFastString file
+ mast | M.size asts == 1 = snd <$> M.lookupMin asts
+ | otherwise = M.lookup fileFs asts
+ ast = fromMaybe (emptyHieAst fileFs) mast
+ fullAst = recoverFullIfaceTypes df types ast
tokens = parse df file rawSrc
+ -- Warn if we didn't find an AST, but there were still ASTs
+ if M.null asts
+ then pure ()
+ else out verbosity verbose $ unwords [ "couldn't find ast for"
+ , file, show (M.keys asts) ]
+
-- Produce and write out the hyperlinked sources
- case mast of
- Just ast ->
- let fullAst = recoverFullIfaceTypes df types ast
- in writeUtf8File path . renderToString pretty . render' fullAst $ tokens
- Nothing
- | M.size asts == 0 -> return ()
- | otherwise -> error $ unwords [ "couldn't find ast for"
- , file, show (M.keys asts) ]
+ writeUtf8File path . renderToString pretty . render' fullAst $ tokens
Nothing -> return ()
where
df = ifaceDynFlags iface
render' = render (Just srcCssFile) (Just highlightScript) srcs
path = srcdir </> hypSrcModuleFile (ifaceMod iface)
+ emptyHieAst fileFs = Node
+ { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)
+ , nodeChildren = []
+ , sourcedNodeInfo = SourcedNodeInfo mempty
+ }
+
-- | Name of CSS file in output directory.
srcCssFile :: FilePath
srcCssFile = "style.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 5fd040a8..3db3c685 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Haddock.Backends.Hyperlinker.Parser (parse) where
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
import Control.Applicative ( Alternative(..) )
-import Control.Monad.Trans.Maybe ( MaybeT(..) )
-import Control.Monad.Trans.Class ( MonadTrans(lift) )
import Data.List ( isPrefixOf, isSuffixOf )
import qualified Data.ByteString as BS
@@ -274,6 +275,7 @@ classify tok =
ITdot -> TkOperator
ITstar {} -> TkOperator
ITtypeApp -> TkGlyph
+ ITpercent -> TkGlyph
ITbiglam -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index ce5ff11c..b093b5a4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -102,7 +102,7 @@ type PrintedType = String
-- > hieAst
--
-- However, this is very inefficient (both in time and space) because the
--- mutliple calls to 'recoverFullType' don't share intermediate results. This
+-- multiple calls to 'recoverFullType' don't share intermediate results. This
-- function fixes that.
recoverFullIfaceTypes
:: DynFlags
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index badb1914..df81fd6e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -39,9 +39,9 @@ import System.FilePath
import Data.Char
import Control.Monad
import Data.Maybe
-import Data.List
+import Data.List ( sort )
+import Data.Void ( absurd )
import Prelude hiding ((<>))
-import GHC.Core.Multiplicity
import Haddock.Doc (combineDocumentation)
@@ -105,6 +105,10 @@ haddockSty = "haddock.sty"
type LaTeX = Pretty.Doc
+-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100
+-- often overflows the line).
+latex2String :: LaTeX -> String
+latex2String = fullRender PageMode 90 1 txtPrinter ""
ppLaTeXTop
:: String
@@ -158,7 +162,7 @@ ppLaTeXModule _title odir iface = do
text "\\haddockbeginheader",
verb $ vcat [
text "module" <+> text mdl_str <+> lparen,
- text " " <> fsep (punctuate (text ", ") $
+ text " " <> fsep (punctuate (char ',') $
map exportListItem $
filter forSummary exports),
text " ) where"
@@ -173,7 +177,7 @@ ppLaTeXModule _title odir iface = do
body = processExports exports
--
- writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
+ writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex)
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
@@ -289,7 +293,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode
+ TyClD _ d@FamDecl {} -> ppFamDecl False 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
@@ -297,7 +301,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
InstD _ _ -> empty
@@ -309,7 +313,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
- ppFunSig doc [name] (hsSigTypeI typ) unicode
+ ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -319,13 +323,14 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-------------------------------------------------------------------------------
-- | Pretty-print a data\/type family declaration
-ppFamDecl :: Documentation DocName -- ^ this decl's docs
+ppFamDecl :: Bool -- ^ is the family associated?
+ -> 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)
+ppFamDecl associated doc instances decl unicode =
+ declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit)
(if null body then Nothing else Just (vcat body))
$$ instancesBit
where
@@ -337,6 +342,7 @@ ppFamDecl doc instances decl unicode =
familyEqns
| FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
+ , not (null eqns)
= Just (text "\\haddockbeginargs" $$
vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
text "\\end{tabulary}\\par")
@@ -356,21 +362,25 @@ ppFamDecl doc instances decl unicode =
-- | Print the LHS of a type\/data family declaration.
ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
- -> Bool -- ^ unicode
- -> LaTeX
+ -> Bool -- ^ unicode
+ -> Bool -- ^ is the family associated?
+ -> LaTeX
ppFamHeader (FamilyDecl { fdLName = L _ name
, fdTyVars = tvs
, fdInfo = info
, fdResultSig = L _ result
, fdInjectivityAnn = injectivity })
- unicode =
- leader <+> keyword "family" <+> famName <+> famSig <+> injAnn
+ unicode associated =
+ famly leader <+> famName <+> famSig <+> injAnn
where
leader = case info of
OpenTypeFamily -> keyword "type"
ClosedTypeFamily _ -> keyword "type"
DataFamily -> keyword "data"
+ famly | associated = id
+ | otherwise = (<+> keyword "family")
+
famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
famSig = case result of
@@ -412,17 +422,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI
- -> Bool -> LaTeX
-ppFunSig doc docnames (L _ typ) unicode =
+ppFunSig
+ :: Maybe LaTeX -- ^ a prefix to put right before the signature
+ -> DocForDecl DocName -- ^ documentation
+ -> [DocName] -- ^ pattern names in the pattern signature
+ -> LHsType DocNameI -- ^ type of the pattern synonym
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFunSig leader doc docnames (L _ typ) unicode =
ppTypeOrFunSig typ doc
- ( ppTypeSig names typ False
- , hsep . punctuate comma $ map ppSymName names
+ ( lead $ ppTypeSig names typ False
+ , lead $ hsep . punctuate comma $ map ppSymName names
, dcolon unicode
)
unicode
where
names = map getName docnames
+ lead = maybe id (<+>) leader
-- | Pretty-print a pattern synonym
ppLPatSig :: DocForDecl DocName -- ^ documentation
@@ -431,15 +447,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation
-> Bool -- ^ unicode
-> LaTeX
ppLPatSig doc docnames ty unicode
- = ppTypeOrFunSig typ doc
- ( keyword "pattern" <+> ppTypeSig names typ False
- , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names)
- , dcolon unicode
- )
- unicode
- where
- typ = unLoc (hsSigTypeI ty)
- names = map getName docnames
+ = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode
-- | Pretty-print a type, adding documentation to the whole type and its
-- arguments as needed.
@@ -459,7 +467,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
@@ -481,8 +489,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
<+> ppLType unicode ltype
) ]
do_args n leader (HsQualTy _ lctxt ltype)
- = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
- : do_largs n (darrow unicode) ltype
+ = ( decltt leader
+ , decltt (ppLContextNoArrow lctxt unicode) <+> nl
+ ) : do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
= [ (decltt ldr, latex <+> nl)
@@ -501,9 +510,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
-- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
-- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
-- mode since `->` and `::` are rendered as single characters.
- gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text ","
- gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}"
- gadtOpen = text "\\{"
+ gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ','
+ gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}'
+ gadtOpen = char '{'
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
@@ -533,10 +542,9 @@ declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
declWithDoc decl doc =
text "\\begin{haddockdesc}" $$
text "\\item[\\begin{tabular}{@{}l}" $$
- text (latexMonoFilter (show decl)) $$
- text "\\end{tabular}]" <>
- (if isNothing doc then empty else text "\\haddockbegindoc") $$
- maybe empty id doc $$
+ text (latexMonoFilter (latex2String decl)) $$
+ text "\\end{tabular}]" $$
+ maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$
text "\\end{haddockdesc}"
@@ -547,9 +555,9 @@ multiDecl :: [LaTeX] -> LaTeX
multiDecl decls =
text "\\begin{haddockdesc}" $$
vcat [
- text "\\item[" $$
- text (latexMonoFilter (show decl)) $$
- text "]"
+ text "\\item[\\begin{tabular}{@{}l}" $$
+ text (latexMonoFilter (latex2String decl)) $$
+ text "\\end{tabular}]"
| decl <- decls ] $$
text "\\end{haddockdesc}"
@@ -593,6 +601,7 @@ ppFds fds unicode =
hsep (map (ppDocName . unLoc) vars2)
+-- TODO: associated type defaults, docs on default methods
ppClassDecl :: [DocInstance DocNameI]
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocNameI -> Bool -> LaTeX
@@ -613,18 +622,28 @@ ppClassDecl instances doc subdocs
body_
| null lsigs, null ats, null at_defs = Nothing
| null ats, null at_defs = Just methodTable
---- | otherwise = atTable $$ methodTable
- | otherwise = error "LaTeX.ppClassDecl"
+ | otherwise = Just (atTable $$ methodTable)
+
+ atTable =
+ text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
+ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
+ | L _ decl <- ats
+ , let name = unLoc . fdLName $ decl
+ doc = lookupAnySubdoc name subdocs
+ ]
+
methodTable =
text "\\haddockpremethods{}" <> emph (text "Methods") $$
- vcat [ ppFunSig doc names (hsSigWcType typ) unicode
- | L _ (TypeSig _ lnames typ) <- lsigs
- , 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?
+ vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode
+ | L _ (ClassOpSig _ is_def lnames typ) <- lsigs
+ , let doc | is_def = noDocForDecl
+ | otherwise = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames
+ leader = if is_def then Just (keyword "default") else Nothing
+ ]
+ -- N.B. taking just the first name is ok. Signatures with multiple
+ -- names are expanded so that each name gets its own signature.
instancesBit = ppDocInstances unicode instances
@@ -643,6 +662,7 @@ ppDocInstances unicode (i : rest)
isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
isUndocdInstance (i,Nothing,_,_) = Just i
+isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i
isUndocdInstance _ = Nothing
-- | Print a possibly commented instance. The instance header is printed inside
@@ -725,15 +745,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 Specificity 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 = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode
+
+ ppCtxt
+ | null ctxt = empty
+ | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space
-- | Pretty-print a constructor
@@ -762,11 +788,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 . hsLTyVarNameI) 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'
@@ -774,7 +799,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
| hasArgDocs -> header_ <+> ppOcc
| otherwise -> hsep [ header_
, ppOcc
- , hsep (map ((ppLParendType unicode) . hsScaledThing) args)
+ , hsep (map (ppLParendType unicode . hsScaledThing) args)
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
@@ -1001,7 +1026,7 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
-ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
@@ -1033,7 +1058,6 @@ ppLKind unicode y = ppKind unicode (unLoc y)
ppKind :: Bool -> HsKind DocNameI -> LaTeX
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
@@ -1060,7 +1084,7 @@ 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 (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"
+ppr_mono_ty (HsSpliceTy v _) _ = absurd v
ppr_mono_ty (HsRecTy {}) _ = text "{..}"
ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
@@ -1086,7 +1110,7 @@ ppr_mono_ty (HsParTy _ ty) unicode
ppr_mono_ty (HsDocTy _ ty _) unicode
= ppr_mono_lty ty unicode
-ppr_mono_ty (HsWildCardTy _) _ = text "\\_"
+ppr_mono_ty (HsWildCardTy _) _ = char '_'
ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
@@ -1120,9 +1144,6 @@ ppSymName name
| otherwise = ppName name
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
-
ppIPName :: HsIPName -> LaTeX
ppIPName = text . ('?':) . unpackFS . hsIPNameFS
@@ -1130,18 +1151,9 @@ ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString
-ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . nameOccName . getName
-
-
-ppVerbRdrName :: RdrName -> LaTeX
-ppVerbRdrName = ppVerbOccName . rdrNameOcc
-
-
ppDocName :: DocName -> LaTeX
ppDocName = ppOccName . nameOccName . getName
-
ppLDocName :: Located DocName -> LaTeX
ppLDocName (L _ d) = ppDocName d
@@ -1179,9 +1191,10 @@ latexMunge c s = c : s
latexMonoMunge :: Char -> String -> String
-latexMonoMunge ' ' s = '\\' : ' ' : s
+latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s
+latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s
latexMonoMunge '\n' s = '\\' : '\\' : s
-latexMonoMunge c s = latexMunge c s
+latexMonoMunge c s = latexMunge c s
-------------------------------------------------------------------------------
@@ -1189,34 +1202,40 @@ latexMonoMunge c s = latexMunge c s
-------------------------------------------------------------------------------
-parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
-parLatexMarkup ppId = Markup {
- markupParagraph = \p v -> p v <> text "\\par" $$ text "",
- markupEmpty = \_ -> empty,
- markupString = \s v -> text (fixString v s),
- markupAppend = \l r v -> l v <> r v,
- markupIdentifier = markupId ppId,
- markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
- markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
- markupWarning = \p v -> emph (p v),
- markupEmphasis = \p v -> emph (p v),
- markupBold = \p v -> bold (p v),
- markupMonospaced = \p _ -> tt (p Mono),
- markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
- markupPic = \p _ -> markupPic p,
- markupMathInline = \p _ -> markupMathInline p,
- markupMathDisplay = \p _ -> markupMathDisplay p,
- markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
- markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
- markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l),
- markupAName = \_ _ -> empty,
- markupProperty = \p _ -> quote $ verb $ text p,
- markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
- markupHeader = \(Header l h) p -> header l (h p),
- markupTable = \(Table h b) p -> table h b p
+latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX)
+latexMarkup = Markup
+ { markupParagraph = \p v -> blockElem (p v (text "\\par"))
+ , markupEmpty = \_ -> id
+ , markupString = \s v -> inlineElem (text (fixString v s))
+ , markupAppend = \l r v -> l v . r v
+ , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i))
+ , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i))
+ , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl)))
+ , markupWarning = \p v -> p v
+ , markupEmphasis = \p v -> inlineElem (emph (p v empty))
+ , markupBold = \p v -> inlineElem (bold (p v empty))
+ , markupMonospaced = \p v -> inlineElem (markupMonospace p v)
+ , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p))
+ , markupPic = \p _ -> inlineElem (markupPic p)
+ , markupMathInline = \p _ -> inlineElem (markupMathInline p)
+ , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p)
+ , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p))
+ , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))
+ , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty)))
+ , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))
+ , markupAName = \_ _ -> id -- TODO
+ , markupProperty = \p _ -> blockElem (quote (verb (text p)))
+ , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e)))
+ , markupHeader = \(Header l h) p -> blockElem (header l (h p empty))
+ , markupTable = \(Table h b) p -> blockElem (table h b p)
}
where
+ blockElem :: LaTeX -> LaTeX -> LaTeX
+ blockElem = ($$)
+
+ inlineElem :: LaTeX -> LaTeX -> LaTeX
+ inlineElem = (<>)
+
header 1 d = text "\\section*" <> braces d
header 2 d = text "\\subsection*" <> braces d
header l d
@@ -1229,6 +1248,9 @@ parLatexMarkup ppId = Markup {
fixString Verb s = s
fixString Mono s = latexMonoFilter s
+ markupMonospace p Verb = p Verb empty
+ markupMonospace p _ = tt (p Mono empty)
+
markupLink url mLabel = case mLabel of
Just label -> text "\\href" <> braces (text url) <> braces label
Nothing -> text "\\url" <> braces (text url)
@@ -1245,35 +1267,28 @@ parLatexMarkup ppId = Markup {
markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]"
- markupId ppId_ id v =
+ markupId v wrappedOcc =
case v of
- Verb -> theid
- Mono -> theid
- Plain -> text "\\haddockid" <> braces theid
- where theid = ppId_ id
-
-
-latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
-latexMarkup = parLatexMarkup ppVerbDocName
-
-
-rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
-rdrLatexMarkup = parLatexMarkup ppVerbRdrName
-
+ Verb -> text i
+ Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i)
+ Plain -> text "\\haddockid" <> braces (text . latexFilter $ i)
+ where i = showWrapped occNameString wrappedOcc
docToLaTeX :: Doc DocName -> LaTeX
-docToLaTeX doc = markup latexMarkup doc Plain
-
+docToLaTeX doc = markup latexMarkup doc Plain empty
documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation
rdrDocToLaTeX :: Doc RdrName -> LaTeX
-rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
+rdrDocToLaTeX doc = markup latexMarkup doc Plain empty
-data StringContext = Plain | Verb | Mono
+data StringContext
+ = Plain -- ^ all special characters have to be escape
+ | Mono -- ^ on top of special characters, escape space chraacters
+ | Verb -- ^ don't escape anything
latexStripTrailingWhitespace :: Doc a -> Doc a
@@ -1298,23 +1313,23 @@ latexStripTrailingWhitespace other = other
itemizedList :: [LaTeX] -> LaTeX
itemizedList items =
- text "\\begin{itemize}" $$
+ text "\\vbox{\\begin{itemize}" $$
vcat (map (text "\\item" $$) items) $$
- text "\\end{itemize}"
+ text "\\end{itemize}}"
enumeratedList :: [LaTeX] -> LaTeX
enumeratedList items =
- text "\\begin{enumerate}" $$
+ text "\\vbox{\\begin{enumerate}" $$
vcat (map (text "\\item " $$) items) $$
- text "\\end{enumerate}"
+ text "\\end{enumerate}}"
descriptionList :: [(LaTeX,LaTeX)] -> LaTeX
descriptionList items =
- text "\\begin{description}" $$
- vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$
- text "\\end{description}"
+ text "\\vbox{\\begin{description}" $$
+ vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$
+ text "\\end{description}}"
tt :: LaTeX -> LaTeX
@@ -1322,8 +1337,8 @@ tt ltx = text "\\haddocktt" <> braces ltx
decltt :: LaTeX -> LaTeX
-decltt ltx = text "\\haddockdecltt" <> braces ltx
-
+decltt ltx = text "\\haddockdecltt" <> braces (text filtered)
+ where filtered = latexMonoFilter (latex2String ltx)
emph :: LaTeX -> LaTeX
emph ltx = text "\\emph" <> braces ltx
@@ -1331,6 +1346,12 @@ emph ltx = text "\\emph" <> braces ltx
bold :: LaTeX -> LaTeX
bold ltx = text "\\textbf" <> braces ltx
+-- TODO: @verbatim@ is too much since
+--
+-- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX
+-- representing that markup gets printed verbatim
+-- * Verbatim environments are not supported everywhere (example: not nested
+-- inside a @tabulary@ environment)
verb :: LaTeX -> LaTeX
verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
-- NB. swallow a trailing \n in the verbatim text by appending the
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 24b565fc..f8c22e0a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -295,6 +295,10 @@ ppHtmlContents state odir doctitle _maybe_package
]
createDirectoryIfMissing True odir
writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+ where
+ -- Extract a module's short description.
+ toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
+ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
@@ -304,6 +308,7 @@ ppPrologue pkg qual title (Just doc) =
ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppSignatureTree _ _ [] = mempty
ppSignatureTree pkg qual ts =
divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
@@ -669,16 +674,22 @@ numberSectionHeadings = go 1
where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]
go _ [] = []
go n (ExportGroup lev _ doc : es)
- = ExportGroup lev (show n) doc : go (n+1) es
+ = case collectAnchors doc of
+ [] -> ExportGroup lev (show n) doc : go (n+1) es
+ (a:_) -> ExportGroup lev a doc : go (n+1) es
go n (other:es)
= other : go n es
+ collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String]
+ collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b
+ collectAnchors (DocAName a) = [a]
+ collectAnchors _ = []
processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> Maybe Html
processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
- = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)
+ = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
= processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ _ qual (ExportNoDecl y [])
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 6e210b61..eeb9fa94 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation)
import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
+import Data.Void ( absurd )
import Text.XHtml hiding ( name, title, p, quote )
import GHC.Core.Type ( Specificity(..) )
@@ -41,7 +42,6 @@ import GHC.Exts
import GHC.Types.Name
import GHC.Data.BooleanFormula
import GHC.Types.Name.Reader ( rdrNameOcc )
-import GHC.Core.Multiplicity
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -76,14 +76,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
- ppFunSig summary links loc doc (map unLoc lnames) lty fixities
+ ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
splice unicode pkg qual
-ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
- ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
+ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =
+ ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)
splice unicode pkg qual HideEmptyContexts
where
pp_typ = ppLType unicode qual HideEmptyContexts typ
@@ -134,8 +134,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.
@@ -155,7 +155,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_args n leader (HsForAllTy _ tele ltype)
= do_largs n leader' ltype
where
- leader' = leader <+> ppForAll tele unicode qual
+ leader' = leader <+> ppForAllPart unicode qual tele
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -189,24 +189,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
gadtOpen = toHtml "{"
-
-ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification
- -> Html
-ppForAll tele unicode qual = case tele of
- HsForAllVis { hsf_vis_bndrs = bndrs } ->
- pp_bndrs bndrs (spaceHtml +++ arrow unicode)
- HsForAllInvis { hsf_invis_bndrs = bndrs } ->
- pp_bndrs bndrs dot
- where
- pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html
- pp_bndrs tvs forall_separator =
- case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
- [] -> noHtml
- ts -> forallSymbol unicode <+> hsep ts +++ forall_separator
-
- pp_ktv 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
@@ -240,7 +222,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode pkg qual
- = ppFunSig summary links loc doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
+ = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -272,10 +254,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
@@ -519,7 +497,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names (hsSigTypeI typ)
+ [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)
[] splice unicode pkg qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -541,7 +519,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
- , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs })
splice unicode pkg qual
| summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
| otherwise = classheader +++ docSection curname pkg qual d
@@ -562,24 +540,61 @@ ppClassDecl summary links instances fixities loc d subdocs
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
- -- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual
- | at <- ats
- , let n = unL . fdLName $ unL at
- doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
- subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
-
- methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigTypeI typ)
- subfixs splice unicode pkg qual
- | L _ (ClassOpSig _ _ lnames typ) <- lsigs
- , name <- map unLoc lnames
- , let doc = lookupAnySubdoc name subdocs
- subfixs = [ f | f@(n',_) <- fixities
- , name == n' ]
- ]
- -- N.B. taking just the first name is ok. Signatures with multiple names
- -- are expanded so that each name gets its own signature.
+ -- Associated types
+ atBit = subAssociatedTypes
+ [ ppAssocType summary links doc at subfixs splice unicode pkg qual
+ <+>
+ subDefaults (maybeToList defTys)
+ | at <- ats
+ , let name = unLoc . fdLName $ unLoc at
+ doc = lookupAnySubdoc name subdocs
+ subfixs = filter ((== name) . fst) fixities
+ defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name
+ ]
+
+ -- Default associated types
+ ppDefaultAssocTy n (vs,rhs) = hsep
+ [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals
+ , ppType unicode qual HideEmptyContexts (unLoc rhs)
+ ]
+ lookupDAT name = Map.lookup (getName name) defaultAssocTys
+ defaultAssocTys = Map.fromList
+ [ (getName name, (vs, typ))
+ | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs }))) <- atsDefs
+ ]
+
+ -- Methods
+ methodBit = subMethods
+ [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)
+ subfixs splice unicode pkg qual
+ <+>
+ subDefaults (maybeToList defSigs)
+ | ClassOpSig _ False lnames typ <- sigs
+ , name <- map unLoc lnames
+ , let doc = lookupAnySubdoc name subdocs
+ subfixs = filter ((== name) . fst) fixities
+ defSigs = ppDefaultFunSig name <$> lookupDM name
+ ]
+ -- N.B. taking just the first name is ok. Signatures with multiple names
+ -- are expanded so that each name gets its own signature.
+
+ -- Default methods
+ ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
+ d' [n] (hsSigTypeI t) [] splice unicode pkg qual
+
+ lookupDM name = Map.lookup (getOccString name) defaultMethods
+ defaultMethods = Map.fromList
+ [ (nameStr, (typ, doc))
+ | ClassOpSig _ True lnames typ <- sigs
+ , name <- map unLoc lnames
+ , let doc = noDocForDecl -- TODO: get docs for method defaults
+ nameStr = getOccString name
+ ]
+
+ -- Minimal complete definition
minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
@@ -603,6 +618,7 @@ ppClassDecl summary links instances fixities loc d subdocs
where wrap | p = parens | otherwise = id
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
+ -- Instances
instancesBit = ppInstances links (OriginClass nm) instances
splice unicode pkg qual
@@ -827,18 +843,16 @@ 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 . hsLTyVarNameI) 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) . hsScaledThing) args)
+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
, noHtml
, noHtml
)
@@ -854,7 +868,7 @@ ppShortConstrParts summary dataInst con unicode qual
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2 ->
- ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
+ ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
]
@@ -901,28 +915,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 . hsLTyVarNameI) 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
- , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppOcc
+ , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) 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 (hsScaledThing arg1)
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
, fixity
@@ -973,17 +986,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 Specificity 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 (HsForAllInvis noExtField tvs)
ppCtxt
| null ctxt = noHtml
@@ -1169,6 +1182,7 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+
ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
ppForAllPart unicode qual tele = case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
@@ -1208,11 +1222,11 @@ 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
-ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v
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
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index ee90ad68..378d0559 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
docElement, docSection, docSection_,
) where
-import Data.List
+import Data.List (intersperse)
import Documentation.Haddock.Markup
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
@@ -171,18 +171,18 @@ flatten x = [x]
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
-hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup fmt' currPkg h' =
let (html, ms) = hackMarkup' fmt' h'
in html +++ renderMeta fmt' currPkg (metaConcat ms)
where
- hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
+ hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
-> (Html, [Meta])
hackMarkup' fmt h = case h of
UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
CollapsingHeader (Header lvl titl) par n nm ->
let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
- col' = collapseControl id_ "caption"
+ col' = collapseControl id_ "subheading"
summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand"
instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents)
lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
@@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml
-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
-markupHacked :: DocMarkup id Html
+markupHacked :: DocMarkup (Wrap id) Html
-> Maybe Package -- this package
-> Maybe String
-> MDoc id
@@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)
-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
@@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw)
origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+ where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))
rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const ppRdrName)
+ where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))
docElement :: (Html -> Html) -> Html -> Html
@@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists)
unParagraph (DocParagraph d) = d
unParagraph doc = doc
- fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
fmtUnParagraphLists = idMarkup {
markupUnorderedList = DocUnorderedList . map unParagraph,
markupOrderedList = DocOrderedList . map unParagraph
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index dd8b0b18..d61d6d9b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout (
subInstances, subOrphanInstances,
subInstHead, subInstDetails, subFamInstDetails,
subMethods,
+ subDefaults,
subMinimal,
topDeclElem, declElem,
@@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
+subDefaults :: [Html] -> Html
+subDefaults = divSubDecls "default" "" . subBlock
+
subMinimal :: Html -> Html
subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 83279f70..8553cdfb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -13,7 +13,8 @@
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinderInfix, ppBinder',
- ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..),
+ ppWrappedDocName, ppWrappedName,
) where
@@ -24,7 +25,7 @@ import Haddock.Utils
import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
-import qualified Data.List as List
+import Data.List ( stripPrefix )
import GHC hiding (LexicalFixity(..))
import GHC.Types.Name
@@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html
ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
-ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-
+ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
+ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
+ where
+ (mdl, occ) = unwrap x
+ occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
@@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName =
ppQualifyName qual notation name (nameModule name)
| otherwise -> ppName notation name
+
+ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
+ppWrappedDocName qual notation insertAnchors docName = case docName of
+ Unadorned n -> ppDocName qual notation insertAnchors n
+ Parenthesized n -> ppDocName qual Prefix insertAnchors n
+ Backticked n -> ppDocName qual Infix insertAnchors n
+
+ppWrappedName :: Notation -> Wrap Name -> Html
+ppWrappedName notation docName = case docName of
+ Unadorned n -> ppName notation n
+ Parenthesized n -> ppName Prefix n
+ Backticked n -> ppName Infix n
+
-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName qual notation name mdl =
@@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl =
then ppName notation name
else ppFullQualName notation mdl name
RelativeQual localmdl ->
- case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ case stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
Just [] -> ppName notation name
-- sub-module, A.B.x -> B.x
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.