aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
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
parent3e29ec51498dfe092b228889343dc8370ec0e64b (diff)
parent1e56f63c3197e7ca1c1e506e083c2bad25d08793 (diff)
Merge commit '1e56f63c3197e7ca1c1e506e083c2bad25d08793' into ghc-9.0
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs17
-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
-rw-r--r--haddock-api/src/Haddock/Convert.hs54
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs149
-rw-r--r--haddock-api/src/Haddock/Interface.hs15
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs180
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs166
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs103
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs229
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs38
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs19
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs31
-rw-r--r--haddock-api/src/Haddock/Options.hs13
-rw-r--r--haddock-api/src/Haddock/Parser.hs42
-rw-r--r--haddock-api/src/Haddock/Types.hs62
-rw-r--r--haddock-api/src/Haddock/Utils.hs184
-rw-r--r--haddock-api/src/Haddock/Utils/Json.hs2
28 files changed, 1175 insertions, 727 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 63ceeb16..8dfee5bc 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -42,6 +42,8 @@ import Haddock.Utils
import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
import Control.Monad hiding (forM_)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Bifunctor (second)
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
@@ -53,9 +55,9 @@ import Data.Version (makeVersion)
import qualified Data.Map as Map
import System.IO
import System.Exit
+import System.FilePath
#ifdef IN_GHC_TREE
-import System.FilePath
import System.Environment (getExecutablePath)
#else
import qualified GHC.Paths as GhcPaths
@@ -67,11 +69,11 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Utils.Outputable (defaultUserStyle, withPprStyle)
import GHC.Utils.Error
import GHC.Unit
import GHC.Utils.Panic (handleGhcException)
import GHC.Data.FastString
-import qualified GHC.Runtime.Loader
--------------------------------------------------------------------------------
-- * Exception handling
@@ -181,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
- putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
+ logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile))
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -424,7 +426,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
withTiming dflags' "ppHyperlinkedSource" (const ()) $ do
_ <- {-# SCC ppHyperlinkedSource #-}
- ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+ ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
return ()
@@ -471,10 +473,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
-- that may need to be re-linked: Haddock doesn't do any
-- dynamic or static linking at all!
_ <- setSessionDynFlags dynflags''
- hscenv <- GHC.getSession
- dynflags''' <- liftIO (GHC.Runtime.Loader.initializePlugins hscenv dynflags'')
- _ <- setSessionDynFlags dynflags'''
- ghcActs dynflags'''
+ ghcActs dynflags''
where
-- ignore sublists of flags that start with "+RTS" and end in "-RTS"
@@ -690,7 +689,7 @@ getPrologue dflags flags =
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! parseParas dflags Nothing str
+ return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str
_ -> throwE "multiple -p/--prologue options"
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.
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index d95337b8..980af379 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -35,7 +35,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Core.PatSyn
-import GHC.Types.SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Core.Type
@@ -58,8 +57,6 @@ import Haddock.Types
import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
-import GHC.Core.Multiplicity
-
import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
@@ -167,8 +164,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
@@ -179,7 +175,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 })
@@ -491,17 +487,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
@@ -626,11 +631,14 @@ synifyType _ vs (TyConApp tc tys)
in noLoc $ HsKindSig noExtField ty' full_kind'
| otherwise = ty'
-synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1
-synifyType _ vs (AppTy t1 t2) = let
- s1 = synifyType WithinType vs t1
- s2 = synifyType WithinType vs t2
- in noLoc $ HsAppTy noExtField s1 s2
+synifyType _ vs ty@(AppTy {}) = let
+ (ty_head, ty_args) = splitAppTys ty
+ ty_head' = synifyType WithinType vs ty_head
+ ty_args' = map (synifyType WithinType vs) $
+ filterOut isCoercionTy $
+ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
+ ty_args
+ in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args'
synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty
synifyType _ vs (FunTy VisArg w t1 t2) = let
s1 = synifyType WithinType vs t1
@@ -822,8 +830,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
@@ -862,8 +870,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 8b4bcc05..10725ee5 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
@@ -20,20 +21,19 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
+import Data.Maybe ( mapMaybe )
import Haddock.Types( DocName, DocNameI )
-import GHC.Utils.Exception
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable, panic, showPpr )
+import GHC.Types.Basic (PromotionFlag(..))
import GHC.Types.Name
-import GHC.Types.Name.Set
import GHC.Unit.Module
import GHC.Driver.Types
import GHC
import GHC.Core.Class
import GHC.Driver.Session
-import GHC.Core.Multiplicity
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -122,6 +122,12 @@ pretty = showPpr
-- These functions are duplicated from the GHC API, as they must be
-- instantiated at DocNameI instead of (GhcPass _).
+-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
+hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n
+hsTyVarBndrName (UserTyVar _ _ name) = unLoc name
+hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name
+hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec
+
hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (UserTyVar _ _ (L _ n)) = n
hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
@@ -234,6 +240,97 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-- Should only be called on ConDeclGADT
+mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
+
+
+addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
+-- Add the class context to a class-op signature
+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
+ = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
+ -- The mkEmptySigWcType is suspicious
+ where
+ go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
+ = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField
+ , hst_body = go ty })
+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ = L loc (HsQualTy { hst_xqual = noExtField
+ , hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ go (L loc ty)
+ = L loc (HsQualTy { hst_xqual = noExtField
+ , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+ extra_pred :: LHsType GhcRn
+ extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))
+
+ add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
+lHsQTyVarsToTypes tvs
+ = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ | tv <- hsQTvExplicit tvs ]
+
+
+--------------------------------------------------------------------------------
+-- * Making abstract declarations
+--------------------------------------------------------------------------------
+
+
+restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
+restrictTo names (L loc decl) = L loc $ case decl of
+ TyClD x d | isDataDecl d ->
+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD x d | isClassDecl d ->
+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
+ tcdATs = restrictATs names (tcdATs d) })
+ _ -> decl
+
+restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
+ | DataType <- new_or_data
+ = defn { dd_cons = restrictCons names cons }
+ | otherwise -- Newtype
+ = case restrictCons names cons of
+ [] -> defn { dd_ND = DataType, dd_cons = [] }
+ [con] -> defn { dd_cons = [con] }
+ _ -> error "Should not happen"
+
+restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
+ where
+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case con_args d of
+ PrefixCon _ -> Just d
+ RecCon fields
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) })
+ -- if we have *all* the field names available, then
+ -- keep the record declaration. Otherwise degrade to
+ -- a constructor declaration. This isn't quite right, but
+ -- it's the best we can do.
+ InfixCon _ _ -> Just d
+ where
+ field_avail :: LConDeclField GhcRn -> Bool
+ field_avail (L _ (ConDeclField _ fs _ _))
+ = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
+
+ field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
+
+ keep _ = Nothing
+
+restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
+
+
+restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
+restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ]
+
+
-------------------------------------------------------------------------------
-- * Parenthesization
-------------------------------------------------------------------------------
@@ -242,6 +339,8 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
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)
@@ -268,18 +367,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 tele ty)
= paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (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 w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
@@ -370,17 +472,17 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
case con_args con of
- RecCon fields -> map (extFieldOcc . unL) $
- concatMap (cd_fld_names . unL) (unL fields)
+ RecCon fields -> map (extFieldOcc . unLoc) $
+ concatMap (cd_fld_names . unLoc) (unLoc fields)
_ -> []
instance Parent (TyClDecl GhcRn) where
children d
- | isDataDecl d = map unL $ concatMap (getConNames . unL)
+ | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc)
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
- map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
+ map (unLoc . fdLName . unLoc) (tcdATs d) ++
+ [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
@@ -390,13 +492,13 @@ family = getName &&& children
familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
-familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
+familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d)
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
families :: TyClDecl GhcRn -> [(Name, [Name])]
families d
- | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
+ | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))
| isClassDecl d = [family d]
| otherwise = []
@@ -436,17 +538,16 @@ minimalDef n = do
-- * DynFlags
-------------------------------------------------------------------------------
-
-setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
-setObjectDir f d = d{ objectDir = Just f}
-setHiDir f d = d{ hiDir = Just f}
-setHieDir f d = d{ hieDir = Just f}
-setStubDir f d = d{ stubDir = Just f
- , includePaths = addGlobalInclude (includePaths d) [f] }
- -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
- -- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f
-
+-- TODO: use `setOutputDir` from GHC
+setOutputDir :: FilePath -> DynFlags -> DynFlags
+setOutputDir dir dynFlags =
+ dynFlags { objectDir = Just dir
+ , hiDir = Just dir
+ , hieDir = Just dir
+ , stubDir = Just dir
+ , includePaths = addGlobalInclude (includePaths dynFlags) [dir]
+ , dumpDir = Just dir
+ }
-------------------------------------------------------------------------------
-- * 'StringBuffer' and 'ByteString'
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index fa20b836..1501919b 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -43,11 +43,11 @@ import Haddock.Types
import Haddock.Utils
import Control.Monad
+import Control.Monad.IO.Class ( liftIO )
import Control.Exception (evaluate)
-import Data.List
+import Data.List (foldl', isPrefixOf, nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Distribution.Verbosity
import Text.Printf
import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
@@ -62,6 +62,7 @@ import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts)
import GHC.Utils.Error (withTimingD)
import GHC.HsToCore.Docs
+import GHC.Runtime.Loader (initializePlugins)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -111,7 +112,7 @@ processModules verbosity modules flags extIfaces = do
let warnings = Flag_NoWarnings `notElem` flags
dflags <- getDynFlags
let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface dflags links warnings) interfaces'
+ runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
@@ -151,7 +152,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'
case isBootSummary modsum of
IsBoot ->
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 0840bd77..6ef0ed19 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -17,11 +19,10 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
-import Haddock.GhcUtils
import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
-import Data.List
+import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index dd9419eb..7fb71d4b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -31,12 +31,13 @@ import Haddock.Interface.LexParseRn
import Data.Bifunctor
import Data.Bitraversable
import qualified Data.Map as M
+import qualified Data.Set as S
import Data.Map (Map)
-import Data.List
+import Data.List (find, foldl')
import Data.Maybe
-import Control.Applicative
import Control.Monad
import Data.Traversable
+import GHC.Stack (HasCallStack)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
@@ -49,7 +50,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State
-import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Tc.Types
import GHC.Data.FastString ( unpackFS, bytesFS )
@@ -58,16 +58,21 @@ import qualified GHC.Utils.Outputable as O
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+mkExceptionContext :: TypecheckedModule -> String
+mkExceptionContext =
+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule
+createInterface :: HasCallStack
+ => TypecheckedModule
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm flags modMap instIfaceMap =
+ withExceptionContext (mkExceptionContext tm) $ do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -85,8 +90,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.
@@ -113,9 +119,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
@@ -127,8 +133,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 ]
@@ -165,6 +171,18 @@ createInterface tm flags modMap instIfaceMap = do
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
+ -- Prune the docstring 'Map's to keep only docstrings that are not private.
+ --
+ -- Besides all the names that GHC has told us this module exports, we also
+ -- keep the docs for locally defined class instances. This is more names than
+ -- we need, but figuring out which instances are fully private is tricky.
+ --
+ -- We do this pruning to avoid having to rename, emit warnings, and save
+ -- docstrings which will anyways never be rendered.
+ let !localVisibleNames = S.fromList (localInsts ++ exportedNames)
+ !prunedDocMap = M.restrictKeys docMap localVisibleNames
+ !prunedArgMap = M.restrictKeys argMap localVisibleNames
+
return $! Interface {
ifaceMod = mdl
, ifaceIsSig = is_sig
@@ -173,12 +191,12 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceDoc = Documentation mbDoc modWarn
, ifaceRnDoc = Documentation Nothing Nothing
, ifaceOptions = opts
- , ifaceDocMap = docMap
- , ifaceArgMap = argMap
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
+ , ifaceDocMap = prunedDocMap
+ , ifaceArgMap = prunedArgMap
+ , ifaceRnDocMap = M.empty -- Filled in `renameInterface`
+ , ifaceRnArgMap = M.empty -- Filled in `renameInterface`
, ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = []
+ , ifaceRnExportItems = [] -- Filled in `renameInterface`
, ifaceExports = exportedNames
, ifaceVisibleExports = visibleNames
, ifaceDeclMap = declMap
@@ -452,7 +470,8 @@ mkFixMap group_ =
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: Bool -- is it a signature
+ :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
-> Module -- this module
@@ -490,7 +509,7 @@ mkExportItems
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= \case
+ findNamedDoc str [ unLoc d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
@@ -511,7 +530,8 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: Bool -- is it a signature
+availExportItem :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Module -- this module
-> Module -- semantic module
@@ -538,13 +558,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
+ let declNames = getMainDeclBinder (unLoc decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
+ Just p <- find isExported (parents t $ unLoc decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
@@ -593,11 +613,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
- availExportDecl :: AvailInfo -> LHsDecl GhcRn
+ -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
+ availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+ availDecl declName parentDecl =
+ case extractDecl declMap declName parentDecl of
+ Right d -> pure d
+ Left err -> do
+ synifiedDeclOpt <- hiDecl dflags declName
+ case synifiedDeclOpt of
+ Just synifiedDecl -> pure synifiedDecl
+ Nothing -> O.pprPanic "availExportItem" (O.text err)
+
+ availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> ErrMsgGhc [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
| availExportsDecl avail = do
+ extractedDecl <- availDecl (availName avail) decl
+
-- bundled pattern synonyms only make sense if the declaration is
-- exported (otherwise there would be nothing to bundle to)
bundledPatSyns <- findBundledPatterns avail
@@ -613,8 +646,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
]
return [ ExportDecl {
- expItemDecl = restrictTo (fmap fst subs)
- (extractDecl declMap (availName avail) decl)
+ expItemDecl = restrictTo (fmap fst subs) extractedDecl
, expItemPats = bundledPatSyns
, expItemMbDoc = doc
, expItemSubDocs = subs
@@ -624,18 +656,18 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
}
]
- | otherwise =
- return [ ExportDecl {
- expItemDecl = extractDecl declMap sub decl
+ | otherwise = for subs $ \(sub, sub_doc) -> do
+ extractedDecl <- availDecl sub decl
+
+ return ( ExportDecl {
+ expItemDecl = extractedDecl
, expItemPats = []
, expItemMbDoc = sub_doc
, expItemSubDocs = []
, expItemInstances = []
, expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
, expItemSpliced = False
- }
- | (sub, sub_doc) <- subs
- ]
+ } )
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
@@ -710,6 +742,7 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
+-- | Reify a declaration from the GHC internal 'TyThing' representation.
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
@@ -852,20 +885,31 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
isSigD (L _ SigD{}) = True
isSigD _ = False
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
+--
+-- This function looks through the declarations in this module to try to find
+-- the one with the right name.
+extractDecl
+ :: HasCallStack
+ => DeclMap -- ^ all declarations in the file
+ -> Name -- ^ name of the declaration to extract
+ -> LHsDecl GhcRn -- ^ parent declaration
+ -> Either ErrMsg (LHsDecl GhcRn)
extractDecl declMap name decl
- | name `elem` getMainDeclBinder (unLoc decl) = decl
+ | name `elem` getMainDeclBinder (unLoc decl) = pure decl
| otherwise =
case unLoc decl of
- TyClD _ d@ClassDecl {} ->
+ TyClD _ d@ClassDecl { tcdLName = L _ clsNm
+ , tcdSigs = clsSigs
+ , tcdATs = clsATs } ->
let
matchesMethod =
[ lsig
- | lsig <- tcdSigs d
+ | lsig <- clsSigs
, ClassOpSig _ False _ _ <- pure $ unLoc lsig
-- Note: exclude `default` declarations (see #505)
, name `elem` sigName lsig
@@ -873,51 +917,54 @@ extractDecl declMap name decl
matchesAssociatedType =
[ lfam_decl
- | lfam_decl <- tcdATs d
+ | lfam_decl <- clsATs
, name == unLoc (fdLName (unLoc lfam_decl))
]
-- TODO: document fixity
in case (matchesMethod, matchesAssociatedType) of
- ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
- L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD noExtField sig)
- (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl))
+ ([s0], _) -> let tyvar_names = tyClDeclTyVars d
+ L pos sig = addClassContext clsNm tyvar_names s0
+ in pure (L pos (SigD noExtField sig))
+ (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
-> extractDecl declMap name famInstDecl
- _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
- O.$$ O.nest 4 (O.ppr d)
- O.$$ O.text "Matches:"
- O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD _ d@DataDecl {} ->
- let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in if isDataConName name
- then SigD noExtField <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD noExtField <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ _ -> Left (concat [ "Ambiguous decl for ", getOccString name
+ , " in class ", getOccString clsNm ])
+
+ TyClD _ d@DataDecl { tcdLName = L _ dataNm
+ , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do
+ let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))
+ lsig <- if isDataConName name
+ then extractPatternSyn name dataNm ty_args dataCons
+ else extractRecSel name dataNm ty_args dataCons
+ pure (SigD noExtField <$> lsig)
+
TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ n
- , feqn_pats = tys
- , feqn_rhs = defn }}))) ->
- if isDataConName name
- then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)
- else SigD noExtField <$> extractRecSel name n tys (dd_cons defn)
+ FamEqn { feqn_tycon = L _ famName
+ , feqn_pats = ty_args
+ , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do
+ lsig <- if isDataConName name
+ then extractPatternSyn name famName ty_args dataCons
+ else extractRecSel name famName ty_args dataCons
+ pure (SigD noExtField <$> lsig)
InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
| isDataConName name ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_rhs = dd
+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons }
}
})) <- insts
- , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
+ , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)
]
in case matches of
[d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))
- _ -> error "internal: extractDecl (ClsInstD)"
+ _ -> Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
@@ -929,16 +976,15 @@ extractDecl declMap name decl
]
in case matches of
[d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)
- _ -> error "internal: extractDecl (ClsInstD)"
- _ -> O.pprPanic "extractDecl" $
- O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
- O.$$ O.nest 4 (O.ppr decl)
+ _ -> Left "internal: extractDecl (ClsInstD)"
+ _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
-extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)
extractPatternSyn nm t tvs cons =
case filter matches cons of
- [] -> error "extractPatternSyn: constructor pattern not found"
- con:_ -> extract <$> con
+ [] -> Left . O.showSDocUnsafe $
+ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
+ con:_ -> pure (extract <$> con)
where
matches :: LConDecl GhcRn -> Bool
matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
@@ -969,13 +1015,13 @@ extractPatternSyn nm t tvs cons =
mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
- -> LSig GhcRn
-extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
+ -> Either ErrMsg (LSig GhcRn)
+extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getConArgs con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))
+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 043a1530..4e271602 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -13,7 +13,6 @@ import GHC.Utils.Outputable
import Control.Arrow
import Data.Map (Map)
-import Data.Bifunctor
import qualified Data.Map as Map
import Haddock.Types
@@ -58,11 +57,172 @@ jsonMap f g = jsonObject . map (f *** g) . Map.toList
jsonMDoc :: MDoc Name -> JsonDoc
jsonMDoc MetaDoc{..} =
jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
- , ("doc", jsonDoc _doc)
+ , ("document", jsonDoc _doc)
]
+showModName :: Wrap (ModuleName, OccName) -> String
+showModName = showWrapped (moduleNameString . fst)
+
+showName :: Wrap Name -> String
+showName = showWrapped nameStableString
+
+
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonDoc DocEmpty = jsonObject
+ [ ("tag", jsonString "DocEmpty") ]
+
+jsonDoc (DocAppend x y) = jsonObject
+ [ ("tag", jsonString "DocAppend")
+ , ("first", jsonDoc x)
+ , ("second", jsonDoc y)
+ ]
+
+jsonDoc (DocString s) = jsonObject
+ [ ("tag", jsonString "DocString")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocParagraph x) = jsonObject
+ [ ("tag", jsonString "DocParagraph")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocIdentifier name) = jsonObject
+ [ ("tag", jsonString "DocIdentifier")
+ , ("name", jsonString (showName name))
+ ]
+
+jsonDoc (DocIdentifierUnchecked modName) = jsonObject
+ [ ("tag", jsonString "DocIdentifierUnchecked")
+ , ("modName", jsonString (showModName modName))
+ ]
+
+jsonDoc (DocModule s) = jsonObject
+ [ ("tag", jsonString "DocModule")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocWarning x) = jsonObject
+ [ ("tag", jsonString "DocWarning")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocEmphasis x) = jsonObject
+ [ ("tag", jsonString "DocEmphasis")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocMonospaced x) = jsonObject
+ [ ("tag", jsonString "DocMonospaced")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocBold x) = jsonObject
+ [ ("tag", jsonString "DocBold")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocUnorderedList xs) = jsonObject
+ [ ("tag", jsonString "DocUnorderedList")
+ , ("documents", jsonArray (fmap jsonDoc xs))
+ ]
+
+jsonDoc (DocOrderedList xs) = jsonObject
+ [ ("tag", jsonString "DocOrderedList")
+ , ("documents", jsonArray (fmap jsonDoc xs))
+ ]
+
+jsonDoc (DocDefList xys) = jsonObject
+ [ ("tag", jsonString "DocDefList")
+ , ("definitions", jsonArray (fmap jsonDef xys))
+ ]
+ where
+ jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)]
+
+jsonDoc (DocCodeBlock x) = jsonObject
+ [ ("tag", jsonString "DocCodeBlock")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocHyperlink hyperlink) = jsonObject
+ [ ("tag", jsonString "DocHyperlink")
+ , ("hyperlink", jsonHyperlink hyperlink)
+ ]
+ where
+ jsonHyperlink Hyperlink{..} = jsonObject
+ [ ("hyperlinkUrl", jsonString hyperlinkUrl)
+ , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel)
+ ]
+
+jsonDoc (DocPic picture) = jsonObject
+ [ ("tag", jsonString "DocPic")
+ , ("picture", jsonPicture picture)
+ ]
+ where
+ jsonPicture Picture{..} = jsonObject
+ [ ("pictureUrl", jsonString pictureUri)
+ , ("pictureLabel", jsonMaybe jsonString pictureTitle)
+ ]
+
+jsonDoc (DocMathInline s) = jsonObject
+ [ ("tag", jsonString "DocMathInline")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocMathDisplay s) = jsonObject
+ [ ("tag", jsonString "DocMathDisplay")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocAName s) = jsonObject
+ [ ("tag", jsonString "DocAName")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocProperty s) = jsonObject
+ [ ("tag", jsonString "DocProperty")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocExamples examples) = jsonObject
+ [ ("tag", jsonString "DocExamples")
+ , ("examples", jsonArray (fmap jsonExample examples))
+ ]
+ where
+ jsonExample Example{..} = jsonObject
+ [ ("exampleExpression", jsonString exampleExpression)
+ , ("exampleResult", jsonArray (fmap jsonString exampleResult))
+ ]
+
+jsonDoc (DocHeader header) = jsonObject
+ [ ("tag", jsonString "DocHeader")
+ , ("header", jsonHeader header)
+ ]
+ where
+ jsonHeader Header{..} = jsonObject
+ [ ("headerLevel", jsonInt headerLevel)
+ , ("headerTitle", jsonDoc headerTitle)
+ ]
+
+jsonDoc (DocTable table) = jsonObject
+ [ ("tag", jsonString "DocTable")
+ , ("table", jsonTable table)
+ ]
+ where
+ jsonTable Table{..} = jsonObject
+ [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows))
+ , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows))
+ ]
+
+ jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells)
+
+ jsonTableCell TableCell{..} = jsonObject
+ [ ("tableCellColspan", jsonInt tableCellColspan)
+ , ("tableCellRowspan", jsonInt tableCellRowspan)
+ , ("tableCellContents", jsonDoc tableCellContents)
+ ]
+
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 2b03ecfa..d1d6bb31 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -19,10 +19,10 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import GHC.Types.Avail
import Control.Arrow
import Control.Monad
-import Data.List
+import Data.Functor (($>))
+import Data.List (maximumBy, (\\))
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
import GHC.Driver.Session (languageExtensions)
@@ -32,10 +32,10 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import GHC.Types.Name
+import GHC.Parser.PostProcess
import GHC.Utils.Outputable ( showPpr, showSDoc )
import GHC.Types.Name.Reader
import GHC.Data.EnumSet as EnumSet
-import GHC.Rename.Env (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 611d8b6f..3e464fbc 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE DeriveFunctor #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.ParseModuleHeader
@@ -11,12 +13,12 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Control.Monad (mplus)
+import Control.Applicative (Alternative (..))
+import Control.Monad (ap)
import Data.Char
import GHC.Driver.Session
import Haddock.Parser
import Haddock.Types
-import GHC.Types.Name.Reader
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -24,37 +26,47 @@ import GHC.Types.Name.Reader
-- 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)
+
+-------------------------------------------------------------------------------
+-- Small parser to parse module header.
+-------------------------------------------------------------------------------
--- | This function is how we read keys.
+-- | The below is a small parser framework how we read keys.
--
-- all fields in the header are optional and have the form
--
@@ -73,78 +85,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 061ef8eb..bb9cd02d 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -28,13 +29,22 @@ import GHC.Builtin.Types (eqTyCon_RDR)
import Control.Applicative
import Control.Arrow ( first )
import Control.Monad hiding (mapM)
-import Data.List
+import Data.List (intercalate)
import qualified Data.Map as Map hiding ( Map )
+import qualified Data.Set as Set
import Prelude hiding (mapM)
import GHC.HsToCore.Docs
-renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface dflags renamingEnv warnings iface =
+-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
+-- 'DocName'.
+--
+-- What this really boils down to is: for each 'Name', figure out which of the
+-- modules that export the name is the preferred place to link to.
+--
+-- The renamed output gets written into fields in the Haddock interface record
+-- that were previously left empty.
+renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface _dflags ignoredSymbols renamingEnv warnings iface =
-- first create the local env, where every name exported by this module
-- is mapped to itself, and everything else comes from the global renaming
@@ -69,8 +79,15 @@ renameInterface dflags renamingEnv warnings iface =
-- Note that since the renamed AST represents equality constraints as
-- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
-- manually filter out 'eqTyCon_RDR' (aka @~@).
- strings = [ pretty dflags n
+
+ qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n
+
+ ignoreSet = Set.fromList ignoredSymbols
+
+ strings = [ qualifiedName n
+
| n <- missingNames
+ , not (qualifiedName n `Set.member` ignoreSet)
, not (isSystemName n)
, not (isBuiltInSyntax n)
, Exact n /= eqTyCon_RDR
@@ -82,7 +99,7 @@ renameInterface dflags renamingEnv warnings iface =
unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
tell ["Warning: " ++ moduleString (ifaceMod iface) ++
": could not find link destinations for:\n"++
- unwords (" " : strings) ]
+ intercalate "\n\t- " ("" : strings) ]
return $ iface { ifaceRnDoc = finalModuleDoc,
ifaceRnDocMap = rnDocMap,
@@ -130,6 +147,11 @@ lookupRn name = RnM $ \lkp ->
(False,maps_to) -> (maps_to, (name :))
(True, maps_to) -> (maps_to, id)
+-- | Look up a 'Name' in the renaming environment, but don't warn if you don't
+-- find the name. Prefer to use 'lookupRn' whenever possible.
+lookupRnNoWarn :: Name -> RnM DocName
+lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id)
+
-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
-- Returns the renamed value along with a list of `Name`'s that could not be
-- renamed because they weren't in the environment.
@@ -173,8 +195,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
@@ -544,7 +566,7 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ src (L l s) -> do
- s' <- traverse renameL s
+ s' <- traverse (traverse lookupRnNoWarn) s
return $ MinimalSig noExtField src (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 0e9fc851..a084af90 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -3,19 +3,20 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Haddock.Interface.Specialize
( specializeInstHead
) where
+import Haddock.GhcUtils ( hsTyVarBndrName )
import Haddock.Syb
import Haddock.Types
import GHC
import GHC.Types.Name
import GHC.Data.FastString
-import GHC.Builtin.Types.Prim ( funTyConName )
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
@@ -57,13 +58,9 @@ specialize specs = go spec_map0
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
-specializeTyVarBndrs bndrs typs =
- specialize $ zip bndrs' typs
+specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
where
- bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar _ _ (L _ name)) = name
- bname (KindedTyVar _ _ (L _ name) _) = name
- bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+ bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
@@ -217,7 +214,7 @@ freeVariables =
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+ bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)
-- | Make given type visually unambiguous.
@@ -365,9 +362,3 @@ alternativeNames name =
located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-
-
-tyVarName :: HsTyVarBndr flag name -> IdP name
-tyVarName (UserTyVar _ _ name) = unLoc name
-tyVarName (KindedTyVar _ _ (L _ name) _) = name
-tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 9686de1f..0b8bb9f2 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -22,12 +22,12 @@ module Haddock.InterfaceFile (
import Haddock.Types
-import Haddock.Utils hiding (out)
import Control.Monad
+import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Array
import Data.IORef
-import Data.List
+import Data.List (mapAccumR)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Word
@@ -84,7 +84,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0)
-binaryInterfaceVersion = 34
+binaryInterfaceVersion = 37
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -702,3 +702,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 5c9bf448..0b886d1a 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -36,14 +36,14 @@ module Haddock.Options (
readIfaceArgs,
optPackageName,
optPackageVersion,
- modulePackageInfo
+ modulePackageInfo,
+ ignoredSymbols
) where
import qualified Data.Char as Char
import Data.Version
import Control.Applicative
-import Distribution.Verbosity
import GHC.Data.FastString
import GHC ( DynFlags, Module, moduleUnit, unitState )
import Haddock.Types
@@ -109,6 +109,7 @@ data Flag
| Flag_PackageVersion String
| Flag_Reexport String
| Flag_SinceQualification String
+ | Flag_IgnoreLinkSymbol String
deriving (Eq, Show)
@@ -220,7 +221,9 @@ options backwardsCompat =
Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
"version of the package being documented in usual x.y.z.w format",
Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
- "package qualification of @since, one of\n'always' (default) or 'only-external'"
+ "package qualification of @since, one of\n'always' (default) or 'only-external'",
+ Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
+ "name of a symbol which does not trigger a warning in case of link issue"
]
@@ -332,11 +335,13 @@ 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
+ignoredSymbols :: [Flag] -> [String]
+ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e1b5c787..0604a831 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Haddock.Parser
-- Copyright : (c) Mateusz Kowalczyk 2013,
@@ -15,26 +16,41 @@ module Haddock.Parser ( parseParas
import qualified Documentation.Haddock.Parser as P
import Documentation.Haddock.Types
+import Haddock.Types
import GHC.Driver.Session ( DynFlags )
import GHC.Data.FastString ( fsLit )
-import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk) )
+import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) )
import GHC.Parser ( parseIdentifier )
-import GHC.Types.Name.Reader ( RdrName )
-import GHC.Types.SrcLoc ( mkRealSrcLoc, unLoc )
+import GHC.Types.Name.Occurrence ( occNameString )
+import GHC.Types.Name.Reader ( RdrName(..) )
+import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..), unLoc )
import GHC.Data.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
- realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
- pstate = mkPState dflags buffer realSrcLc
- in case unP parseIdentifier pstate of
- POk _ name -> Just (unLoc name)
- _ -> Nothing
+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
+parseIdent dflags ns str0 =
+ case unP parseIdentifier (pstate str1) of
+ POk _ (L _ name)
+ -- Guards against things like 'Q.--', 'Q.case', etc.
+ -- See https://github.com/haskell/haddock/issues/952 and Trac #14109
+ | Qual _ occ <- name
+ , PFailed{} <- unP parseIdentifier (pstate (occNameString occ))
+ -> Nothing
+ | otherwise
+ -> Just (wrap (NsRdrName ns name))
+ PFailed{} -> Nothing
+ where
+ realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
+ pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc
+ (wrap,str1) = case str0 of
+ '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names
+ -> (Parenthesized, init s)
+ '`' : s@(_ : _) -> (Backticked, init s)
+ _ -> (Unadorned, str0)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 21c7d19b..aa76f8f6 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -27,14 +27,16 @@ module Haddock.Types (
, module Documentation.Haddock.Types
) where
-import Control.Exception
import Control.Arrow hiding ((<+>))
import Control.DeepSeq
+import Control.Exception (throw)
import Control.Monad (ap)
+import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO(..))
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
+import Data.Void (Void)
import Documentation.Haddock.Types
import GHC.Types.Basic (Fixity(..), PromotionFlag(..))
@@ -284,6 +286,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
@@ -330,7 +338,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
@@ -424,10 +455,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
@@ -620,17 +651,28 @@ tell w = Writer ((), w)
-- | Haddock's own exception type.
-data HaddockException = HaddockException String deriving Typeable
+data HaddockException
+ = HaddockException String
+ | WithContext [String] SomeException
+ deriving Typeable
instance Show HaddockException where
show (HaddockException str) = str
-
+ show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
throwE :: String -> a
instance Exception HaddockException
throwE str = throw (HaddockException str)
+withExceptionContext :: MonadCatch m => String -> m a -> m a
+withExceptionContext ctxt =
+ handle (\ex ->
+ case ex of
+ HaddockException _ -> throwM $ WithContext [ctxt] (toException ex)
+ WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se
+ ) .
+ handle (throwM . WithContext [ctxt])
-- In "Haddock.Interface.Create", we need to gather
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
@@ -665,6 +707,12 @@ instance Monad ErrMsgGhc where
instance MonadIO ErrMsgGhc where
liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
+instance MonadThrow ErrMsgGhc where
+ throwM e = WriterGhc (throwM e)
+
+instance MonadCatch ErrMsgGhc where
+ catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f))
+
-----------------------------------------------------------------------------
-- * Pass sensitive types
-----------------------------------------------------------------------------
@@ -685,7 +733,7 @@ type instance XOpTy DocNameI = NoExtField
type instance XParTy DocNameI = NoExtField
type instance XIParamTy DocNameI = NoExtField
type instance XKindSig DocNameI = NoExtField
-type instance XSpliceTy DocNameI = NoExtField
+type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`
type instance XDocTy DocNameI = NoExtField
type instance XBangTy DocNameI = NoExtField
type instance XRecTy DocNameI = NoExtField
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 8346a477..0c9c6073 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -13,15 +13,9 @@
-----------------------------------------------------------------------------
module Haddock.Utils (
- -- * Misc utilities
- restrictTo, emptyHsQTvs,
- toDescription, toInstalledDescription,
- mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
-
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
contentsHtmlFile, indexHtmlFile, indexJsonFile,
- moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
haddockJsFile, jsQuickJumpFile,
quickJumpCssFile,
@@ -32,7 +26,7 @@ module Haddock.Utils (
makeAnchorId,
-- * Miscellaneous utilities
- getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ getProgramName, bye, die, escapeStr,
writeUtf8File, withTempDir,
-- * HTML cross reference mapping
@@ -45,11 +39,8 @@ module Haddock.Utils (
replace,
spanWith,
- -- * MTL stuff
- MonadIO(..),
-
-- * Logging
- parseVerbosity,
+ parseVerbosity, Verbosity(..), silent, normal, verbose, deafening,
out,
-- * System tools
@@ -59,48 +50,54 @@ module Haddock.Utils (
import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types
-import Haddock.GhcUtils
-import GHC.Types.Basic ( PromotionFlag(..) )
-import GHC.Utils.Exception (ExceptionMonad)
import GHC
import GHC.Types.Name
-import Control.Monad ( liftM )
-import Control.Monad.Catch ( bracket_ )
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Control.Monad.Catch ( MonadMask, bracket_ )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
import Numeric ( showIntAtBase )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
-import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit
import System.Directory ( createDirectory, removeDirectoryRecursive )
-import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
+import System.IO ( hPutStr, hSetEncoding, IOMode(..), 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
#endif
-import GHC.Utils.Monad ( MonadIO(..) )
-
-import GHC.Core.Multiplicity
-
-
--------------------------------------------------------------------------------
-- * 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
@@ -117,115 +114,14 @@ out progVerbosity msgVerbosity msg
--------------------------------------------------------------------------------
--- | Extract a module's short description.
-toDescription :: Interface -> Maybe (MDoc Name)
-toDescription = fmap mkMeta . hmi_description . ifaceInfo
-
-
--- | Extract a module's short description.
-toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
-toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
-mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
-
-addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
--- Add the class context to a class-op signature
-addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
- -- The mkEmptySigWcType is suspicious
- where
- go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
- = L loc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = tele, hst_body = go ty })
- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt ctxt, hst_body = ty })
- go (L loc ty)
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
-
- extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt (L loc preds) = L loc (extra_pred : preds)
-
-addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-
-lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
-lHsQTyVarsToTypes tvs
- = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
- | tv <- hsQTvExplicit tvs ]
-
---------------------------------------------------------------------------------
--- * Making abstract declarations
---------------------------------------------------------------------------------
-
-
-restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
-restrictTo names (L loc decl) = L loc $ case decl of
- TyClD x d | isDataDecl d ->
- TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD x d | isClassDecl d ->
- TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
- tcdATs = restrictATs names (tcdATs d) })
- _ -> decl
-
-restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
- | DataType <- new_or_data
- = defn { dd_cons = restrictCons names cons }
- | otherwise -- Newtype
- = case restrictCons names cons of
- [] -> defn { dd_ND = DataType, dd_cons = [] }
- [con] -> defn { dd_cons = [con] }
- _ -> error "Should not happen"
-
-restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
- where
- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
- case con_args d of
- PrefixCon _ -> Just d
- RecCon fields
- | all field_avail (unL fields) -> Just d
- | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
- InfixCon _ _ -> Just d
- where
- field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField _ fs _ _))
- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
- field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ]
-
- keep _ = Nothing
-
-restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-
-
-restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-
-emptyHsQTvs :: LHsQTyVars GhcRn
--- This function is here, rather than in HsTypes, because it *renamed*, but
--- does not necessarily have all the rigt kind variables. It is used
--- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs"
- , hsq_explicit = [] }
-
-
--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
--------------------------------------------------------------------------------
-
baseName :: ModuleName -> FilePath
baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
@@ -252,13 +148,6 @@ indexHtmlFile = "doc-index.html"
indexJsonFile = "doc-index.json"
-
-moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
-moduleIndexFrameName = "modules"
-mainFrameName = "main"
-synopsisFrameName = "synopsis"
-
-
subIndexHtmlFile :: String -> String
subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
where b | all isAlpha ls = ls
@@ -332,7 +221,7 @@ quickJumpCssFile = "quick-jump.css"
getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+getProgramName = fmap (`withoutSuffix` ".bin") getProgName
where str `withoutSuffix` suff
| suff `isSuffixOf` str = take (length str - length suff) str
| otherwise = str
@@ -341,25 +230,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
bye :: String -> IO a
bye s = putStr s >> exitSuccess
-
-dieMsg :: String -> IO ()
-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
-
-
-noDieMsg :: String -> IO ()
-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
-
-
-mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
-mapSnd _ [] = []
-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
-
-
-mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM _ Nothing = return Nothing
-mapMaybeM f (Just a) = liftM Just (f a)
-
-
escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved
@@ -406,9 +276,9 @@ writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
hSetEncoding h utf8
hPutStr h contents
-withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
+withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTempDir dir = bracket_ (liftIO $ createDirectory dir)
- (liftIO $ removeDirectoryRecursive dir)
+ (liftIO $ removeDirectoryRecursive dir)
-----------------------------------------------------------------------------
-- * HTML cross references
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
index e3c3dddc..2270a547 100644
--- a/haddock-api/src/Haddock/Utils/Json.hs
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -19,7 +19,7 @@ import Data.Char
import Data.Int
import Data.String
import Data.Word
-import Data.List
+import Data.List (intersperse)
import Data.Monoid
import Data.ByteString.Builder (Builder)