aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs49
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs306
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs183
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs18
-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
-rw-r--r--haddock-api/src/Haddock/Convert.hs40
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs14
-rw-r--r--haddock-api/src/Haddock/Interface.hs10
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs13
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs101
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs228
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs27
-rw-r--r--haddock-api/src/Haddock/Options.hs3
-rw-r--r--haddock-api/src/Haddock/Parser.hs22
-rw-r--r--haddock-api/src/Haddock/Types.hs37
-rw-r--r--haddock-api/src/Haddock/Utils.hs25
23 files changed, 695 insertions, 443 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index b76d14b5..1f98ef9c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -254,13 +254,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
- tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
- tyVarArg _ = panic "ppCtor"
+ resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat))
+ as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
+ in apps (map reL (c : as))
- resType = apps $ map reL $
- (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
- map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
+ tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn
+ tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k
+ tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor"
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
= concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
@@ -325,7 +326,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 7571db9e..3f5483fe 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,12 +18,13 @@ import Data.Maybe
import System.Directory
import System.FilePath
-import HieTypes ( HieFile(..), HieASTs(..) )
+import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) )
import HieBin ( readHieFile, hie_file_result)
import Data.Map as M
import FastString ( mkFastString )
import Module ( Module, moduleName )
import NameCache ( initNameCache )
+import SrcLoc ( mkRealSrcLoc, realSrcLocSpan )
import UniqSupply ( mkSplitUniqSupply )
@@ -32,27 +33,28 @@ import UniqSupply ( 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'
@@ -64,25 +66,38 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
<$> (readHieFile (initNameCache u []) 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)
+ emptyNodeInfo = NodeInfo
+ { nodeAnnotations = mempty
+ , nodeType = []
+ , nodeIdentifiers = mempty
+ }
+ emptyHieAst fileFs = Node
+ { nodeInfo = emptyNodeInfo
+ , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)
+ , nodeChildren = []
+ }
+
-- | 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 e9029ae6..0247d567 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -9,7 +9,7 @@ import qualified Data.ByteString as BS
import BasicTypes ( IntegralLit(..) )
import DynFlags
-import ErrUtils ( emptyMessages, pprLocErrMsg )
+import ErrUtils ( pprLocErrMsg )
import FastString ( mkFastString )
import Lexer ( P(..), ParseResult(..), PState(..), Token(..)
, mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError )
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 67eb10b5..612f3f08 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 6fd7969f..f2fb1041 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -103,6 +103,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
@@ -156,7 +160,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"
@@ -171,7 +175,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
@@ -287,7 +291,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
@@ -295,7 +299,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
@@ -307,7 +311,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"
@@ -317,13 +321,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
@@ -335,6 +340,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,22 +362,26 @@ ppFamDecl doc instances decl unicode =
-- | Print the LHS of a type\/data family declaration.
ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
- -> Bool -- ^ unicode
- -> LaTeX
-ppFamHeader (XFamilyDecl nec) _ = noExtCon nec
+ -> Bool -- ^ unicode
+ -> Bool -- ^ is the family associated?
+ -> LaTeX
+ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec
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
@@ -414,17 +424,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
@@ -433,15 +449,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.
@@ -461,7 +469,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
@@ -479,13 +487,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
do_args _n leader (HsForAllTy _ fvf tvs ltype)
= [ ( decltt leader
- , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++
- [ppForAllSeparator unicode fvf]))
+ , decltt (ppForAllPart unicode tvs fvf)
<+> 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 _ (L _ (HsRecTy _ fields)) r)
= [ (decltt ldr, latex <+> nl)
@@ -504,9 +512,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 '{'
ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
@@ -522,8 +530,9 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX]
-ppTyVars = map (ppSymName . getName . hsLTyVarNameI)
+-- | Pretty-print type variables.
+ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX]
+ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)
tyvarNames :: LHsQTyVars DocNameI -> [Name]
@@ -534,10 +543,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}"
@@ -548,9 +556,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}"
@@ -594,6 +602,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
@@ -614,18 +623,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 = unL . 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
@@ -644,6 +663,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
@@ -726,15 +746,21 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX
-ppConstrHdr forall tvs ctxt unicode
- = (if null tvs then empty else ppForall)
- <+>
- (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
+ppConstrHdr
+ :: Bool -- ^ print explicit foralls
+ -> [LHsTyVarBndr DocNameI] -- ^ type variables
+ -> HsContext DocNameI -- ^ context
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
where
- ppForall = case forall of
- True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
- False -> empty
+ ppForall
+ | null tvs || not forall_ = empty
+ | otherwise = ppForAllPart unicode tvs ForallInvis
+
+ ppCtxt
+ | null ctxt = empty
+ | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space
-- | Pretty-print a constructor
@@ -763,11 +789,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'
@@ -1004,7 +1029,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
@@ -1017,7 +1042,7 @@ ppLHsTypeArg _ (HsArgPar _) = text ""
ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
- parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+ parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind)
ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
@@ -1030,14 +1055,22 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
+ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX
+ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv
+ where
+ tvs' = ppTyVars unicode tvs
+ fv = case fvf of
+ ForallVis -> text "\\ " <> arrow unicode
+ ForallInvis -> dot
+
+
ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
- = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <>
- ppForAllSeparator unicode fvf
+ = sep [ ppForAllPart unicode tvs fvf
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
@@ -1051,7 +1084,7 @@ ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
-ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind
ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
@@ -1080,7 +1113,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)
@@ -1114,9 +1147,6 @@ ppSymName name
| otherwise = ppName name
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
-
ppIPName :: HsIPName -> LaTeX
ppIPName = text . ('?':) . unpackFS . hsIPNameFS
@@ -1124,18 +1154,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
@@ -1173,9 +1194,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
-------------------------------------------------------------------------------
@@ -1183,34 +1205,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
@@ -1223,6 +1251,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)
@@ -1239,35 +1270,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
@@ -1292,23 +1316,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
@@ -1316,8 +1340,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
@@ -1325,6 +1349,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/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a24715a7..c7ae15ca 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -36,11 +36,11 @@ import Text.XHtml hiding ( name, title, p, quote )
import BasicTypes (PromotionFlag(..), isPromoted)
import GHC hiding (LexicalFixity(..))
+import qualified GHC
import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
-import Outputable ( panic )
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -75,14 +75,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
@@ -133,8 +133,8 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
curname = getName <$> listToMaybe docnames
--- This splits up a type signature along `->` and adds docs (when they exist) to
--- the arguments.
+-- | This splits up a type signature along @->@ and adds docs (when they exist)
+-- to the arguments.
--
-- If one passes in a list of the available subdocs, any top-level `HsRecTy`
-- found will be expanded out into their fields.
@@ -152,9 +152,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
do_args n leader (HsForAllTy _ fvf tvs ltype)
- = do_largs n leader' ltype
- where
- leader' = leader <+> ppForAll tvs unicode qual fvf
+ = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -188,22 +186,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
gadtOpen = toHtml "{"
-
-ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> ForallVisFlag
- -> Html
-ppForAll tvs unicode qual fvf =
- case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
- [] -> noHtml
- ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf
- where ppKTv n k = parens $
- ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
-
-ppForAllSeparator :: Unicode -> ForallVisFlag -> Html
-ppForAllSeparator unicode fvf =
- case fvf of
- ForallVis -> spaceHtml +++ arrow unicode
- ForallInvis -> dot
-
ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
@@ -236,7 +218,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"
@@ -268,10 +250,6 @@ ppTypeSig summary nms pp_ty unicode =
htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
-ppTyName :: Name -> Html
-ppTyName = ppName Prefix
-
-
ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-> [DocName] -> HsType DocNameI
-> Html
@@ -518,7 +496,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
@@ -539,8 +517,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)
-> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
-> 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 })
+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm)
+ , tcdTyVars = ltyvars, 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
@@ -557,28 +536,63 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Only the fixity relevant to the class header
fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
- nm = tcdName decl
-
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 = unL . fdLName $ unL 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] ==
@@ -587,7 +601,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -602,6 +616,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
@@ -828,24 +843,23 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualificati
ppShortConstrParts summary dataInst con unicode qual
= case con of
ConDeclH98{ con_args = det
- , con_ex_tvs = vars
+ , con_ex_tvs = tyVars
+ , con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let tyVars = map (getName . 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) args)
+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
, noHtml
, noHtml
)
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
RecCon (L _ fields) ->
- ( header_ +++ ppOcc <+> char '{'
+ ( header_ <+> ppOcc <+> char '{'
, shortSubDecls dataInst [ ppShortField summary unicode qual field
| L _ field <- fields
]
@@ -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 arg1
+ ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts arg2
]
@@ -902,28 +916,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
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppOcc
, hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
, fixity
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
- RecCon _ -> header_ +++ ppOcc <+> fixity
+ RecCon _ -> header_ <+> ppOcc <+> fixity
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2
- | hasArgDocs -> header_ +++ ppOcc <+> fixity
- | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts arg2
, fixity
@@ -976,17 +989,17 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -- ^ print explicit foralls
- -> [Name] -- ^ type variables
- -> HsContext DocNameI -- ^ context
- -> Unicode -> Qualification -> Html
+ppConstrHdr
+ :: Bool -- ^ print explicit foralls
+ -> [LHsTyVarBndr DocNameI] -- ^ type variables
+ -> HsContext DocNameI -- ^ context
+ -> Unicode -> Qualification
+ -> Html
ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
where
ppForall
| null tvs || not forall_ = noHtml
- | otherwise = forallSymbol unicode
- <+> hsep (map (ppName Prefix) tvs)
- <+> toHtml ". "
+ | otherwise = ppForAllPart unicode qual tvs ForallInvis
ppCtxt
| null ctxt = noHtml
@@ -1159,10 +1172,14 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
-ppForAllPart :: Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr DocNameI] -> Html
-ppForAllPart unicode qual fvf tvs =
- hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++
- ppForAllSeparator unicode fvf
+
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html
+ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv
+ where
+ tvs' = ppTyVars unicode qual tvs
+ fv = case fvf of
+ ForallVis -> spaceHtml +++ arrow unicode
+ ForallInvis -> dot
ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
@@ -1170,7 +1187,7 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts
- = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
+ = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts
ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
@@ -1195,7 +1212,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u q _ =
ppr_mono_ty (HsSumTy _ tys) u q _ =
sumParens (map (ppLType u q HideEmptyContexts) tys)
ppr_mono_ty (HsKindSig _ ty kind) u q e =
- parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind)
+ ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind
ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 09aabc0c..edab4b16 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -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 25d8b07a..4535b897 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 574045e0..6a047747 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 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.
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6e2c0b9f..d5fa3667 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -44,7 +44,7 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
, liftedRepDataConKey )
import Unique ( getUnique )
-import Util ( chkAppend,dropList, filterByList, filterOut )
+import Util ( chkAppend, dropList, filterByList, filterOut )
import Var
import VarSet
@@ -150,8 +150,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
args_types_only = filterOutInvisibleTypes tc args
typats = map (synifyType WithinType []) args_types_only
- annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
- args_types_only typats
+ annot_typats = zipWith3 annotHsType args_poly args_types_only typats
hs_rhs = synifyType WithinType [] rhs
in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExtField
@@ -162,7 +161,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
, feqn_fixity = synifyFixity name
, feqn_rhs = hs_rhs } }
where
- fam_tvs = tyConVisibleTyVars tc
+ args_poly = tyConArgsPolyKinded tc
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
@@ -469,17 +468,26 @@ annotHsType True ty hs_ty
in noLoc (HsKindSig noExtField hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
--- | For every type variable in the input,
--- report whether or not the tv is poly-kinded. This is used to eventually
--- feed into 'annotHsType'.
-mkIsPolyTvs :: [TyVar] -> [Bool]
-mkIsPolyTvs = map is_poly_tv
+-- | For every argument type that a type constructor accepts,
+-- report whether or not the argument is poly-kinded. This is used to
+-- eventually feed into 'annotThType'.
+tyConArgsPolyKinded :: TyCon -> [Bool]
+tyConArgsPolyKinded tc =
+ map (is_poly_ty . tyVarKind) tc_vis_tvs
+ ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs
+ ++ repeat True
where
- is_poly_tv tv = not $
+ is_poly_ty :: Type -> Bool
+ is_poly_ty ty = not $
isEmptyVarSet $
filterVarSet isTyVar $
- tyCoVarsOfType $
- tyVarKind tv
+ tyCoVarsOfType ty
+
+ tc_vis_tvs :: [TyVar]
+ tc_vis_tvs = tyConVisibleTyVars tc
+
+ tc_res_kind_vis_bndrs :: [TyCoBinder]
+ tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc
--states of what to do with foralls:
data SynifyTypeState
@@ -773,8 +781,8 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
ts' = map (synifyType WithinType vs) ts
- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
+ annot_ts = zipWith3 annotHsType args_poly ts ts'
+ args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
-- Convert a family instance, this could be a type family or data family
@@ -813,8 +821,8 @@ synifyFamInst fi opaque = do
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
synifyTypes = map (synifyType WithinType [])
ts' = synifyTypes ts
- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
+ annot_ts = zipWith3 annotHsType args_poly ts ts'
+ args_poly = tyConArgsPolyKinded fam_tc
{-
Note [Invariant: Never expand type synonyms]
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index cef1e6e9..6577e08f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -38,7 +38,8 @@ import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
isInvisibleArgFlag )
import VarSet ( VarSet, emptyVarSet )
import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
-import TyCoRep ( Type(..), isRuntimeRepVar )
+import TyCoRep ( Type(..) )
+import Type ( isRuntimeRepVar )
import TysWiredIn( liftedRepDataConTyCon )
import StringBuffer ( StringBuffer )
@@ -260,6 +261,8 @@ getGADTConTypeG (XConDecl nec) = noExtCon nec
data Precedence
= PREC_TOP -- ^ precedence of 'type' production in GHC's parser
+ | PREC_SIG -- ^ explicit type signature
+
| PREC_CTX -- ^ Used for single contexts, eg. ctx => type
-- (as opposed to (ctx1, ctx2) => type)
@@ -286,18 +289,21 @@ reparenTypePrec = go
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
- go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
+ go p (HsKindSig x ty kind)
+ = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind)
go p (HsIParamTy x n ty)
- = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
+ = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty)
go p (HsForAllTy x fvf tvs ty)
= paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)
go p (HsQualTy x ctxt ty)
- = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
+ = let p' [_] = PREC_CTX
+ p' _ = PREC_TOP -- parens will get added anyways later...
+ in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)
go p (HsFunTy x ty1 ty2)
= paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 998116f4..c2c0d733 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -47,7 +47,6 @@ import Control.Exception (evaluate)
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Distribution.Verbosity
import Text.Printf
import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
@@ -61,6 +60,7 @@ import Name (nameIsFromExternalPackage, nameOccName)
import OccName (isTcOcc)
import RdrName (unQualOK, gre_name, globalRdrEnvElts)
import ErrUtils (withTimingD)
+import DynamicLoading (initializePlugins)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -150,7 +150,13 @@ createIfaces verbosity modules flags instIfaceMap = do
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
- tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
+
+ -- Since GHC 8.6, plugins are initialized on a per module basis
+ hsc_env' <- getSession
+ dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum))
+ let modsum' = modsum { ms_hspp_opts = dynflags' }
+
+ tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum'
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 361c91de..d5cbdaf5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -84,8 +84,9 @@ createInterface tm flags modMap instIfaceMap = do
(TcGblEnv { tcg_rdr_env = gre
, tcg_warns = warnings
- , tcg_exports = all_exports
+ , tcg_exports = all_exports0
}, md) = tm_internals_ tm
+ all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre
-- The 'pkgName' is necessary to decide what package to mention in "@since"
-- annotations. Not having it is not fatal though.
@@ -112,9 +113,9 @@ createInterface tm flags modMap instIfaceMap = do
let declsWithDocs = topDecls group_
exports0 = fmap (map (first unLoc)) mayExports
- exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
+ (all_exports, exports)
+ | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
+ | otherwise = (all_exports0, exports0)
unrestrictedImportedMods
-- module re-exports are only possible with
@@ -126,8 +127,8 @@ createInterface tm flags modMap instIfaceMap = do
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom sem_mdl)
- $ map getName instances
- ++ map getName fam_instances
+ $ map getName fam_instances
+ ++ map getName instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 636d3e19..a9834fa0 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} =
]
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+jsonDoc doc = jsonString (show (bimap showModName showName doc))
+ where
+ showModName = showWrapped (moduleNameString . fst)
+ showName = showWrapped nameStableString
jsonModule :: Module -> JsonDoc
jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 59ad4fdf..0b40ed3c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -19,9 +19,9 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import Avail
import Control.Arrow
import Control.Monad
+import Data.Functor (($>))
import Data.List
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
@@ -34,8 +34,8 @@ import Haddock.Types
import Name
import Outputable ( showPpr, showSDoc )
import RdrName
+import RdrHsSyn (setRdrNameSpace)
import EnumSet
-import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -89,24 +89,38 @@ processModuleHeader dflags pkgName gre safety mayStr = do
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
+rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
- DocIdentifier x -> do
+ DocIdentifier i -> do
+ let NsRdrName ns x = unwrap i
+ occ = rdrNameOcc x
+ isValueName = isDataOcc occ || isVarOcc occ
+
+ let valueNsChoices | isValueName = [x]
+ | otherwise = [] -- is this ever possible?
+ typeNsChoices | isValueName = [setRdrNameSpace x tcName]
+ | otherwise = [x]
+
-- Generate the choices for the possible kind of thing this
- -- is.
- let choices = dataTcOccs x
+ -- is. We narrow down the possibilities with the namespace (if
+ -- there is one).
+ let choices = case ns of
+ Value -> valueNsChoices
+ Type -> typeNsChoices
+ None -> valueNsChoices ++ typeNsChoices
-- Lookup any GlobalRdrElts that match the choices.
case concatMap (\c -> lookupGRE_RdrName c gre) choices of
-- We found no names in the env so we start guessing.
[] ->
case choices of
- -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
- [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+ -- The only way this can happen is if a value namespace was
+ -- specified on something that cannot be a value.
+ [] -> invalidValue dflags i
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
@@ -116,14 +130,14 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags a
+ a:_ -> outOfScope dflags ns (i $> a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (gre_name a))
+ [a] -> pure (DocIdentifier (i $> gre_name a))
-- There are multiple names available.
- gres -> ambiguous dflags x gres
+ gres -> ambiguous dflags i gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -155,19 +169,25 @@ rename dflags gre = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a)
-outOfScope dflags x =
- case x of
- Unqual occ -> warnAndMonospace occ
- Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
- Orig _ occ -> warnAndMonospace occ
- Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
+outOfScope dflags ns x =
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
+ prefix = case ns of
+ Value -> "the value "
+ Type -> "the type "
+ None -> ""
+
warnAndMonospace a = do
- tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
+ let a' = showWrapped (showPpr dflags) a
+ tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
" If you qualify the identifier, haddock can try to link it anyway."]
- pure (monospaced a)
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ pure (monospaced a')
+ monospaced = DocMonospaced . DocString
-- | Handle ambiguous identifiers.
--
@@ -175,26 +195,39 @@ outOfScope dflags x =
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous :: DynFlags
- -> RdrName
+ -> Wrap NsRdrName
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
- let noChildren = map availName (gresToAvailInfo gres)
- dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+ let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres
+ msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by hiding some imports.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ " by specifying the type/value namespace explicitly.\n" ++
+ " Defaulting to the one defined " ++ defnLoc dflt
-- TODO: Once we have a syntax for namespace qualification (#667) we may also
-- want to emit a warning when an identifier is a data constructor for a type
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
- when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier dflt)
+ when (length (gresToAvailInfo gres) > 1) $ tell [msg]
+ pure (DocIdentifier (x $> gre_name dflt))
+ where
+ defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name
+
+-- | Handle value-namespaced names that cannot be for values.
+--
+-- Emits a warning that the value-namespace is invalid on a non-value identifier.
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
+invalidValue dflags x = do
+ tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
+ " namespaced as such. Did you mean to specify a type namespace\n" ++
+ " instead?"]
+ pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
- isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
- isLocalName _ = False
- x_str = '\'' : showPpr dflags x ++ "'"
- defnLoc = showSDoc dflags . pprNameDefnLoc
+ ident = showWrapped (showPpr dflags . rdrName)
+ prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 050901b6..37813d16 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -11,12 +12,12 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Control.Monad (mplus)
+import Control.Applicative (Alternative (..))
+import Control.Monad (ap)
import Data.Char
import DynFlags
import Haddock.Parser
import Haddock.Types
-import RdrName
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -24,37 +25,47 @@ import RdrName
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader dflags pkgName str0 =
let
- getKey :: String -> String -> (Maybe String,String)
- getKey key str = case parseKey key str of
- Nothing -> (Nothing,str)
- Just (value,rest) -> (Just value,rest)
-
- (_moduleOpt,str1) = getKey "Module" str0
- (descriptionOpt,str2) = getKey "Description" str1
- (copyrightOpt,str3) = getKey "Copyright" str2
- (licenseOpt,str4) = getKey "License" str3
- (licenceOpt,str5) = getKey "Licence" str4
- (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5
- (maintainerOpt,str7) = getKey "Maintainer" str6
- (stabilityOpt,str8) = getKey "Stability" str7
- (portabilityOpt,str9) = getKey "Portability" str8
+ kvs :: [(String, String)]
+ str1 :: String
+
+ (kvs, str1) = maybe ([], str0) id $ runP fields str0
+
+ -- trim whitespaces
+ trim :: String -> String
+ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+ getKey :: String -> Maybe String
+ getKey key = fmap trim (lookup key kvs)
+
+ descriptionOpt = getKey "Description"
+ copyrightOpt = getKey "Copyright"
+ licenseOpt = getKey "License"
+ licenceOpt = getKey "Licence"
+ spdxLicenceOpt = getKey "SPDX-License-Identifier"
+ maintainerOpt = getKey "Maintainer"
+ stabilityOpt = getKey "Stability"
+ portabilityOpt = getKey "Portability"
in (HaddockModInfo {
hmi_description = parseString dflags <$> descriptionOpt,
hmi_copyright = copyrightOpt,
- hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt,
+ hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt,
hmi_maintainer = maintainerOpt,
hmi_stability = stabilityOpt,
hmi_portability = portabilityOpt,
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags pkgName str9)
+ }, parseParas dflags pkgName str1)
--- | This function is how we read keys.
+-------------------------------------------------------------------------------
+-- Small parser to parse module header.
+-------------------------------------------------------------------------------
+
+-- | The below is a small parser framework how we read keys.
--
-- all fields in the header are optional and have the form
--
@@ -73,78 +84,105 @@ parseModuleHeader dflags pkgName str0 =
--
-- the value will be "this is a .. description" and the rest will begin
-- at "The module comment".
-parseKey :: String -> String -> Maybe (String,String)
-parseKey key toParse0 =
- do
- let
- (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0)
-
- indentation = spaces0
- afterKey0 <- extractPrefix key toParse1
- let
- afterKey1 = extractLeadingSpaces afterKey0
- afterColon0 <- case snd afterKey1 of
- ':':afterColon -> return afterColon
- _ -> Nothing
- let
- (_,afterColon1) = extractLeadingSpaces afterColon0
-
- return (scanKey True indentation afterColon1)
- where
- scanKey :: Bool -> String -> String -> (String,String)
- scanKey _ _ [] = ([],[])
- scanKey isFirst indentation str =
- let
- (nextLine,rest1) = extractNextLine str
-
- accept = isFirst || sufficientIndentation || allSpaces
-
- sufficientIndentation = case extractPrefix indentation nextLine of
- Just (c:_) | isSpace c -> True
- _ -> False
-
- allSpaces = case extractLeadingSpaces nextLine of
- (_,[]) -> True
- _ -> False
- in
- if accept
- then
- let
- (scanned1,rest2) = scanKey False indentation rest1
-
- scanned2 = case scanned1 of
- "" -> if allSpaces then "" else nextLine
- _ -> nextLine ++ "\n" ++ scanned1
- in
- (scanned2,rest2)
- else
- ([],str)
-
- extractLeadingSpaces :: String -> (String,String)
- extractLeadingSpaces [] = ([],[])
- extractLeadingSpaces (s@(c:cs))
- | isSpace c =
- let
- (spaces1,cs1) = extractLeadingSpaces cs
- in
- (c:spaces1,cs1)
- | otherwise = ([],s)
-
- extractNextLine :: String -> (String,String)
- extractNextLine [] = ([],[])
- extractNextLine (c:cs)
- | c == '\n' =
- ([],cs)
- | otherwise =
- let
- (line,rest) = extractNextLine cs
- in
- (c:line,rest)
-
- -- comparison is case-insensitive.
- extractPrefix :: String -> String -> Maybe String
- extractPrefix [] s = Just s
- extractPrefix _ [] = Nothing
- extractPrefix (c1:cs1) (c2:cs2)
- | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
- | otherwise = Nothing
+
+-- | 'C' is a 'Char' carrying its column.
+--
+-- This let us make an indentation-aware parser, as we know current indentation.
+-- by looking at the next character in the stream ('curInd').
+--
+-- Thus we can munch all spaces but only not-spaces which are indented.
+--
+data C = C {-# UNPACK #-} !Int Char
+
+newtype P a = P { unP :: [C] -> Maybe ([C], a) }
+ deriving Functor
+
+instance Applicative P where
+ pure x = P $ \s -> Just (s, x)
+ (<*>) = ap
+
+instance Monad P where
+ return = pure
+ m >>= k = P $ \s0 -> do
+ (s1, x) <- unP m s0
+ unP (k x) s1
+
+instance Alternative P where
+ empty = P $ \_ -> Nothing
+ a <|> b = P $ \s -> unP a s <|> unP b s
+
+runP :: P a -> String -> Maybe a
+runP p input = fmap snd (unP p input')
+ where
+ input' = concat
+ [ zipWith C [0..] l ++ [C (length l) '\n']
+ | l <- lines input
+ ]
+
+-------------------------------------------------------------------------------
+--
+-------------------------------------------------------------------------------
+
+curInd :: P Int
+curInd = P $ \s -> Just . (,) s $ case s of
+ [] -> 0
+ C i _ : _ -> i
+
+rest :: P String
+rest = P $ \cs -> Just ([], [ c | C _ c <- cs ])
+
+munch :: (Int -> Char -> Bool) -> P String
+munch p = P $ \cs ->
+ let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs)
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+munch1 :: (Int -> Char -> Bool) -> P String
+munch1 p = P $ \s -> case s of
+ [] -> Nothing
+ (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs)
+ | otherwise -> Nothing
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+char :: Char -> P Char
+char c = P $ \s -> case s of
+ [] -> Nothing
+ (C _ c' : cs) | c == c' -> Just (cs, c)
+ | otherwise -> Nothing
+
+skipSpaces :: P ()
+skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ())
+
+takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
+takeWhileMaybe f = go where
+ go xs0@[] = ([], xs0)
+ go xs0@(x:xs) = case f x of
+ Just y -> let (ys, zs) = go xs in (y : ys, zs)
+ Nothing -> ([], xs0)
+
+-------------------------------------------------------------------------------
+-- Fields
+-------------------------------------------------------------------------------
+
+field :: Int -> P (String, String)
+field i = do
+ fn <- munch1 $ \_ c -> isAlpha c || c == '-'
+ skipSpaces
+ _ <- char ':'
+ skipSpaces
+ val <- munch $ \j c -> isSpace c || j > i
+ return (fn, val)
+
+fields :: P ([(String, String)], String)
+fields = do
+ skipSpaces
+ i <- curInd
+ fs <- many (field i)
+ r <- rest
+ return (fs, r)
+
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 5b96c0a0..72d063dc 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 36729d70..b5be311a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811)
-binaryInterfaceVersion = 34
+binaryInterfaceVersion = 35
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -701,3 +701,28 @@ instance Binary DocName where
name <- get bh
return (Undocumented name)
_ -> error "get DocName: Bad h"
+
+instance Binary n => Binary (Wrap n) where
+ put_ bh (Unadorned n) = do
+ putByte bh 0
+ put_ bh n
+ put_ bh (Parenthesized n) = do
+ putByte bh 1
+ put_ bh n
+ put_ bh (Backticked n) = do
+ putByte bh 2
+ put_ bh n
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- get bh
+ return (Unadorned name)
+ 1 -> do
+ name <- get bh
+ return (Parenthesized name)
+ 2 -> do
+ name <- get bh
+ return (Backticked name)
+ _ -> error "get Wrap: Bad h"
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index e314bbd0..510810b0 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -43,7 +43,6 @@ module Haddock.Options (
import qualified Data.Char as Char
import Data.Version
import Control.Applicative
-import Distribution.Verbosity
import FastString
import GHC ( DynFlags, Module, moduleUnitId )
import Haddock.Types
@@ -332,7 +331,7 @@ sinceQualification flags =
verbosity :: [Flag] -> Verbosity
verbosity flags =
case [ str | Flag_Verbosity str <- flags ] of
- [] -> normal
+ [] -> Normal
x:_ -> case parseVerbosity x of
Left e -> throwE e
Right v -> v
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e31ea6a8..6d5dc103 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -15,26 +15,32 @@ module Haddock.Parser ( parseParas
import qualified Documentation.Haddock.Parser as P
import Documentation.Haddock.Types
+import Haddock.Types
import DynFlags ( DynFlags )
import FastString ( fsLit )
import Lexer ( mkPState, unP, ParseResult(POk) )
import Parser ( parseIdentifier )
-import RdrName ( RdrName )
-import SrcLoc ( mkRealSrcLoc, unLoc )
+import SrcLoc ( mkRealSrcLoc, GenLocated(..) )
import StringBuffer ( stringToStringBuffer )
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName
+
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
-parseString :: DynFlags -> String -> DocH mod RdrName
+parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
parseString d = P.overIdentifier (parseIdent d) . P.parseString
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
- let buffer = stringToStringBuffer str0
+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
+parseIdent dflags ns str0 =
+ let buffer = stringToStringBuffer str1
realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
pstate = mkPState dflags buffer realSrcLc
+ (wrap,str1) = case str0 of
+ '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names
+ -> (Parenthesized, init s)
+ '`' : s@(_ : _) -> (Backticked, init s)
+ _ -> (Unadorned, str0)
in case unP parseIdentifier pstate of
- POk _ name -> Just (unLoc name)
+ POk _ (L _ name) -> Just (wrap (NsRdrName ns name))
_ -> Nothing
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b5659038..28e3caed 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -42,7 +42,7 @@ import GHC
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
import OccName
-import Outputable
+import Outputable hiding ((<>))
-----------------------------------------------------------------------------
-- * Convenient synonyms
@@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty)
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
+-- | An 'RdrName' tagged with some type/value namespace information.
+data NsRdrName = NsRdrName
+ { namespace :: !Namespace
+ , rdrName :: !RdrName
+ }
+
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
@@ -328,7 +334,30 @@ instance SetName DocName where
setName name' (Documented _ mdl) = Documented name' mdl
setName name' (Undocumented _) = Undocumented name'
+-- | Adds extra "wrapper" information to a name.
+--
+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',
+-- 'OccName', ...) don't include backticks or parens.
+data Wrap n
+ = Unadorned { unwrap :: n } -- ^ don't do anything to the name
+ | Parenthesized { unwrap :: n } -- ^ add parentheses around the name
+ | Backticked { unwrap :: n } -- ^ add backticks around the name
+ deriving (Show, Functor, Foldable, Traversable)
+
+-- | Useful for debugging
+instance Outputable n => Outputable (Wrap n) where
+ ppr (Unadorned n) = ppr n
+ ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]
+ ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ]
+
+showWrapped :: (a -> String) -> Wrap a -> String
+showWrapped f (Unadorned n) = f n
+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
+showWrapped f (Backticked n) = "`" ++ f n ++ "`"
+
+instance HasOccName DocName where
+ occName = occName . getName
-----------------------------------------------------------------------------
-- * Instances
@@ -423,10 +452,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where
type LDoc id = Located (Doc id)
-type Doc id = DocH (ModuleName, OccName) id
-type MDoc id = MetaDoc (ModuleName, OccName) id
+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)
+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
-type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index d817e4fa..79673365 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -49,7 +49,7 @@ module Haddock.Utils (
MonadIO(..),
-- * Logging
- parseVerbosity,
+ parseVerbosity, Verbosity(..), silent, normal, verbose, deafening,
out,
-- * System tools
@@ -81,8 +81,6 @@ import System.Directory ( createDirectory, removeDirectoryRecursive )
import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
-import Distribution.Verbosity
-import Distribution.ReadE
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
@@ -95,10 +93,27 @@ import MonadUtils ( MonadIO(..) )
-- * Logging
--------------------------------------------------------------------------------
+data Verbosity = Silent | Normal | Verbose | Deafening
+ deriving (Eq, Ord, Enum, Bounded, Show)
-parseVerbosity :: String -> Either String Verbosity
-parseVerbosity = runReadE flagToVerbosity
+silent, normal, verbose, deafening :: Verbosity
+silent = Silent
+normal = Normal
+verbose = Verbose
+deafening = Deafening
+-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing.
+parseVerbosity :: String -> Either String Verbosity
+parseVerbosity "0" = Right Silent
+parseVerbosity "1" = Right Normal
+parseVerbosity "2" = Right Silent
+parseVerbosity "3" = Right Deafening
+parseVerbosity "silent" = return Silent
+parseVerbosity "normal" = return Normal
+parseVerbosity "verbose" = return Verbose
+parseVerbosity "debug" = return Deafening
+parseVerbosity "deafening" = return Deafening
+parseVerbosity other = Left ("Can't parse verbosity " ++ other)
-- | Print a message to stdout, if it is not too verbose
out :: MonadIO m