aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorPaolo Capriotti <p.capriotti@gmail.com>2012-07-19 16:28:45 +0100
committerPaolo Capriotti <p.capriotti@gmail.com>2012-07-19 16:49:32 +0100
commit6e8bc1dca77bbbc5743f63a2e8ea5b1eab0ed80c (patch)
tree5f4ad32677af3e2b95e468e5bcab94c38e5d88e1 /src
parent105f31e1b5b1428ae27590893740017327d322ff (diff)
parent2a931d32cfdbd20d4da0cff6415a3aaf47823938 (diff)
Forward port changes from stable.
Diffstat (limited to 'src')
-rw-r--r--src/.ghci1
-rw-r--r--src/Haddock/Backends/Hoogle.hs33
-rw-r--r--src/Haddock/Backends/LaTeX.hs55
-rw-r--r--src/Haddock/Backends/Xhtml.hs35
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs99
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs11
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs9
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs33
-rw-r--r--src/Haddock/Backends/Xhtml/Utils.hs15
-rw-r--r--src/Haddock/Interface/Create.hs319
-rw-r--r--src/Haddock/Interface/LexParseRn.hs78
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs6
-rw-r--r--src/Haddock/Interface/Rename.hs38
-rw-r--r--src/Haddock/InterfaceFile.hs48
-rw-r--r--src/Haddock/Lex.x3
-rw-r--r--src/Haddock/Options.hs16
-rw-r--r--src/Haddock/Types.hs79
-rw-r--r--src/Haddock/Utils.hs11
-rw-r--r--src/Main.hs28
19 files changed, 531 insertions, 386 deletions
diff --git a/src/.ghci b/src/.ghci
new file mode 100644
index 00000000..f00e6d55
--- /dev/null
+++ b/src/.ghci
@@ -0,0 +1 @@
+:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 9c5d57c3..55f6ac1d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -48,11 +48,11 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
hClose h
ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface
- = "" : doc dflags (ifaceDoc iface) ++
- ["module " ++ moduleString (ifaceMod iface)] ++
- concatMap (ppExport dflags) (ifaceExportItems iface) ++
- concatMap (ppInstance dflags) (ifaceInstances iface)
+ppModule dflags iface =
+ "" : ppDocumentation dflags (ifaceDoc iface) ++
+ ["module " ++ moduleString (ifaceMod iface)] ++
+ concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap (ppInstance dflags) (ifaceInstances iface)
---------------------------------------------------------------------
@@ -102,7 +102,7 @@ out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dfla
operator :: String -> String
-operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")"
+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
operator x = x
@@ -110,7 +110,7 @@ operator x = x
-- How to print each export
ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags (ExportDecl decl dc subdocs _) = doc dflags (fst dc) ++ f (unL decl)
+ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
f (TyClD d@TyDecl{})
| isDataDecl d = ppData dflags d subdocs
@@ -127,7 +127,7 @@ ppSig :: DynFlags -> Sig Name -> [String]
ppSig dflags (TypeSig names sig)
= [operator prettyNames ++ " :: " ++ outHsType dflags typ]
where
- prettyNames = concat . intersperse ", " $ map (out dflags) names
+ prettyNames = intercalate ", " $ map (out dflags) names
typ = case unL sig of
HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
x -> x
@@ -172,19 +172,19 @@ ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
-lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name)
-lookupCon subdocs (L _ name) = case lookup name subdocs of
- Just (d, _) -> d
- _ -> Nothing
+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> ppDocumentation dflags d
+ _ -> []
ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dflags dat subdocs con = doc dflags (lookupCon subdocs (con_name con))
+ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
++ f (con_details con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [doc dflags (lookupCon subdocs (cd_fld_name r)) ++
+ [lookupCon dflags subdocs (cd_fld_name r) ++
[out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
| r <- recs]
@@ -203,6 +203,10 @@ ppCtor dflags dat subdocs con = doc dflags (lookupCon subdocs (con_name con))
---------------------------------------------------------------------
-- DOCUMENTATION
+ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w
+
+
doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
doc dflags = docWith dflags ""
@@ -242,6 +246,7 @@ markupTag dflags = Markup {
markupIdentifier = box (TagInline "a") . str . out dflags,
markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
markupModule = box (TagInline "a") . str,
+ markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
markupMonospaced = box (TagInline "tt"),
markupPic = const $ str " ",
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index f03801bb..c187f104 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -157,9 +157,7 @@ ppLaTeXModule _title odir iface = do
]
description
- = case ifaceRnDoc iface of
- Nothing -> empty
- Just doc -> docToLaTeX doc
+ = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
body = processExports exports
--
@@ -209,7 +207,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
- (Nothing, argDocs) _ _)
+ (Documentation Nothing Nothing, argDocs) _ _)
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -275,26 +273,25 @@ ppDecl :: LHsDecl DocName
-> [(DocName, DocForDecl DocName)]
-> LaTeX
-ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode
+ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
+ TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode
TyClD d@(TyDecl{ tcdTyDefn = defn })
- | isHsDataDefn defn -> ppDataDecl instances subdocs loc mbDoc d unicode
- | otherwise -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
--- | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d
+ | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode
+ | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
--- | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode
+-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode
- SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
- ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode
+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
where
unicode = False
-ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
TyClDecl DocName -> Bool -> LaTeX
ppTyFam _ _ _ _ _ =
error "type family declarations are currently not supported by --latex"
@@ -346,13 +343,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
unicode
| Map.null argDocs =
- declWithDoc pref1 (fmap docToLaTeX doc)
+ declWithDoc pref1 (documentationToLaTeX doc)
| otherwise =
declWithDoc pref2 $ Just $
text "\\haddockbeginargs" $$
do_args 0 sep0 typ $$
text "\\end{tabulary}\\par" $$
- maybe empty docToLaTeX doc
+ fromMaybe empty (documentationToLaTeX doc)
where
do_largs n leader (L _ t) = do_args n leader t
@@ -460,9 +457,9 @@ ppFds fds unicode =
ppClassDecl :: [DocInstance DocName] -> SrcSpan
- -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+ -> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> LaTeX
-ppClassDecl instances loc mbDoc subdocs
+ppClassDecl instances loc doc subdocs
(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
= declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
@@ -474,7 +471,7 @@ ppClassDecl instances loc mbDoc subdocs
hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
- body = catMaybes [fmap docToLaTeX mbDoc, body_]
+ body = catMaybes [documentationToLaTeX doc, body_]
body_
| null lsigs, null ats, null at_defs = Nothing
@@ -515,8 +512,8 @@ isUndocdInstance _ = Nothing
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, mbDoc) =
- declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc)
+ppDocInstance unicode (instHead, doc) =
+ declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)
ppInstDecl :: Bool -> InstHead DocName -> LaTeX
@@ -542,9 +539,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
ppDataDecl :: [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
+ppDataDecl instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
@@ -554,7 +551,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
- body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
+ body = catMaybes [constrBit, documentationToLaTeX doc]
(whereBit, leaders)
| null cons = (empty,[])
@@ -634,8 +631,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
forall = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- -- 'join' is in Maybe.
- mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
@@ -645,7 +641,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = join $ fmap fst $ lookup name subdocs
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
-- {-
-- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -997,6 +993,7 @@ parLatexMarkup ppId = Markup {
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),
markupMonospaced = \p _ -> tt (p Mono),
markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
@@ -1033,6 +1030,10 @@ docToLaTeX :: Doc DocName -> LaTeX
docToLaTeX doc = markup latexMarkup doc Plain
+documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
+documentationToLaTeX = fmap docToLaTeX . combineDocumentation
+
+
rdrDocToLaTeX :: Doc RdrName -> LaTeX
rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 50aad789..c68b7cbc 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -66,7 +66,7 @@ ppHtml :: String
-> Maybe String -- ^ The contents URL (--use-contents)
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
- -> Qualification -- ^ How to qualify names
+ -> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> IO ()
@@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
themes maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces)
False -- we don't want to display the packages in a single-package contents
- prologue debug qual
+ prologue debug (makeContentsQual qual)
when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
@@ -175,7 +175,7 @@ bodyHtml doctitle iface
contentsButton maybe_contents_url,
indexButton maybe_index_url])
! [theclass "links", identifier "page-menu"],
- nonEmpty sectionName << doctitle
+ nonEmptySectionName << doctitle
],
divContent << pageContent,
divFooter << paragraph << (
@@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
indexLinks nm entries
many_entities ->
td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
- aboves (map doAnnotatedEntity (zip [1..] many_entities))
+ aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
doAnnotatedEntity (j,(nm,entries))
@@ -461,18 +461,16 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool -> Qualification
+ -> Maybe String -> Maybe String -> Bool -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug iface = do
let
mdl = ifaceMod iface
+ aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
- real_qual = case qual of
- LocalQual Nothing -> LocalQual (Just mdl)
- RelativeQual Nothing -> RelativeQual (Just mdl)
- _ -> qual
+ real_qual = makeModuleQual qual aliases mdl
html =
headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
bodyHtml doctitle (Just iface)
@@ -484,8 +482,7 @@ ppHtmlModule odir doctitle themes
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
-
+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-> Interface -> Bool -> Qualification -> Bool -> IO ()
@@ -511,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
+ has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
no_doc_at_all = not (any has_doc exports)
- description
- = case ifaceRnDoc iface of
- Nothing -> noHtml
- Just doc -> divDescription $
- sectionName << "Description" +++ docSection qual doc
+ description | isNoHtml doc = doc
+ | otherwise = divDescription $ sectionName << "Description" +++ doc
+ where doc = docSection qual (ifaceRnDoc iface)
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -539,7 +534,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
maybe_doc_hdr
= case exports of
[] -> noHtml
- ExportGroup _ _ _ : _ -> noHtml
+ ExportGroup {} : _ -> noHtml
_ -> h1 << "Documentation"
bdy =
@@ -617,7 +612,7 @@ ppModuleContents qual exports
-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
-numberSectionHeadings exports = go 1 exports
+numberSectionHeadings = go 1
where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
go _ [] = []
go n (ExportGroup lev _ doc : es)
@@ -638,7 +633,7 @@ processExport summary _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
ppDocName qual y +++ parenList (map (ppDocName qual) subs)
processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection qual doc
+ = nothingIf summary $ docSection_ qual doc
processExport summary _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index b5ad1a8f..59be34f7 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -26,16 +26,15 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
-import Control.Monad ( join )
import Data.List ( intersperse )
import qualified Data.Map as Map
+import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
import GHC
import Name
--- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
@@ -68,14 +67,14 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc
+ | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc
| otherwise = topDeclElem links loc docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
+ subArguments qual (do_args 0 sep typ) +++ docSection qual doc
where
argDoc n = Map.lookup n argDocs
do_largs n leader (L _ t) = do_args n leader t
- do_args :: Int -> Html -> (HsType DocName) -> [SubDecl]
+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]
do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
= (leader <+>
hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
@@ -95,7 +94,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
= (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = (leader <+> ppType unicode qual t, argDoc n, []) : []
+ = [(leader <+> ppType unicode qual t, argDoc n, [])]
ppTyVars :: LHsTyVarBndrs DocName -> [Html]
@@ -165,12 +164,12 @@ ppTyFamHeader summary associated decl unicode qual =
Nothing -> noHtml
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc mbDoc decl unicode qual
+ppTyFam summary associated links loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
+ | otherwise = header_ +++ docSection qual doc +++ instancesBit
where
docname = tcdName decl
@@ -249,12 +248,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc
ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
ppContextNoArrow [] _ _ = noHtml
-ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
ppContextNoLocs [] _ _ = noHtml
-ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual
+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
<+> darrow unicode
@@ -262,10 +261,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
-pp_hs_context [] _ _ = noHtml
-pp_hs_context [p] unicode qual = ppType unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html
+ppHsContext [] _ _ = noHtml
+ppHsContext [p] unicode qual = ppType unicode qual p
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
-------------------------------------------------------------------------------
@@ -279,8 +278,8 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
- <+> ppFds fds unicode qual
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> ppFds fds unicode qual
ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
@@ -324,13 +323,13 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
- -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+ -> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> Qualification -> Html
-ppClassDecl summary links instances loc mbDoc subdocs
+ppClassDecl summary links instances loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs unicode qual
- | otherwise = classheader +++ maybeDocSection qual mbDoc
+ | otherwise = classheader +++ docSection qual d
+++ atBit +++ methodBit +++ instancesBit
where
classheader
@@ -354,7 +353,7 @@ ppClassDecl summary links instances loc mbDoc subdocs
-- there are different subdocs for different names in a single
-- type signature?
- instancesBit = ppInstances instances nm unicode qual
+ instancesBit = ppInstances instances nm unicode qual
ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
@@ -371,11 +370,8 @@ ppInstances instances baseName unicode qual
<+> ppAppNameTypes n ts unicode qual
-lookupAnySubdoc :: (Eq name1) =>
- name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
-lookupAnySubdoc n subdocs = case lookup n subdocs of
- Nothing -> noDocForDecl
- Just docs -> docs
+lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-------------------------------------------------------------------------------
@@ -388,7 +384,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
-> Qualification -> Html
ppShortDataDecl summary _links _loc dataDecl unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons = dataHeader
| [lcon] <- cons, ResTyH98 <- resTy,
(cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual
@@ -411,12 +407,12 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
Qualification -> Html
-ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
+ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
| summary = ppShortDataDecl summary links loc dataDecl unicode qual
- | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit
+ | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
docname = unLoc . tcdLName $ dataDecl
@@ -471,7 +467,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
-- (except each field gets its own line in docs, to match
-- non-GADT records)
RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
- ppForAll forall ltvs lcontext unicode qual <+> char '{',
+ ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
@@ -479,29 +475,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of
where
doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields)
doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs lcontext unicode qual,
+ ppForAll forall_ ltvs lcontext unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr forall_ tyVars context
occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
context = unLoc (con_cxt con)
- forall = con_explicit con
+ forall_ = con_explicit con
mkFunTy a b = noLoc (HsFunTy a b)
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
-> Qualification -> Html
-ppConstrHdr forall tvs ctxt unicode qual
+ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
(if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
<+> darrow unicode +++ toHtml " ")
where
- ppForall = case forall of
+ ppForall = case forall_ of
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> noHtml
@@ -539,19 +535,18 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
doGADTCon args resTy =
ppBinder False occ <+> dcolon unicode
- <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,
+ <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr forall_ tyVars context
occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
- forall = con_explicit con
+ forall_ = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- -- 'join' is in Maybe.
- mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
@@ -563,7 +558,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
[])
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = join $ fmap fst $ lookup name subdocs
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
@@ -609,13 +604,13 @@ tupleParens _ = parenList
pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
-pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
-pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = (2 :: Int) -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = (3 :: Int) -- Used for arg of type applicn:
- -- always parenthesise unless atomic
+pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
+pREC_FUN = 1 :: Int -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = 2 :: Int -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = 3 :: Int -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
maybeParen :: Int -- Precedence of context
-> Int -- Precedence of top-level operator
@@ -657,7 +652,7 @@ ppForAll expl tvs cxt unicode qual
ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
-ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
@@ -675,11 +670,7 @@ ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
-#if __GLASGOW_HASKELL__ == 612
-ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#else
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#endif
ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index f506d2b8..052116ee 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
rdrDocToHtml,
origDocToHtml,
- docElement, docSection, maybeDocSection,
+ docElement, docSection, docSection_,
) where
@@ -39,6 +39,7 @@ parHtmlMarkup qual ppId = Markup {
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
markupModule = \m -> let (mdl,ref) = break (=='#') m
in ppModuleRef (mkModuleName mdl) ref,
+ markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupMonospaced = thecode,
markupUnorderedList = unordList,
@@ -84,12 +85,12 @@ docElement el content_ =
else el ! [theclass "doc"] << content_
-docSection :: Qualification -> Doc DocName -> Html
-docSection qual = (docElement thediv <<) . docToHtml qual
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
-maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
-maybeDocSection qual = maybe noHtml (docSection qual)
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index bdd5ac78..3ddbd28b 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout (
divIndex, divAlphabet, divModuleList,
sectionName,
+ nonEmptySectionName,
shortDeclList,
shortSubDecls,
@@ -66,6 +67,14 @@ sectionName :: Html -> Html
sectionName = paragraph ! [theclass "caption"]
+-- | Make an element that always has at least something (a non-breaking space).
+-- If it would have otherwise been empty, then give it the class ".empty".
+nonEmptySectionName :: Html -> Html
+nonEmptySectionName c
+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
+ | otherwise = paragraph ! [theclass "caption"] $ c
+
+
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynposis, divInterface,
divIndex, divAlphabet, divModuleList
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index f07f42e0..2f2b82ed 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -25,6 +25,7 @@ import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.Map as M
import qualified Data.List as List
import GHC
@@ -57,7 +58,10 @@ ppDocName qual docName =
case docName of
Documented name mdl ->
linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
- Undocumented name -> ppQualifyName qual name (nameModule name)
+ Undocumented name
+ | isExternalName name || isWiredInName name ->
+ ppQualifyName qual name (nameModule name)
+ | otherwise -> ppName name
-- | Render a name depending on the selected qualification mode
@@ -66,28 +70,33 @@ ppQualifyName qual name mdl =
case qual of
NoQual -> ppName name
FullQual -> ppFullQualName mdl name
- -- this is just in case, it should never happen
- LocalQual Nothing -> ppQualifyName FullQual name mdl
- LocalQual (Just localmdl)
- | moduleString mdl == moduleString localmdl -> ppName name
- | otherwise -> ppFullQualName mdl name
- -- again, this never happens
- RelativeQual Nothing -> ppQualifyName FullQual name mdl
- RelativeQual (Just localmdl) ->
+ LocalQual localmdl ->
+ if moduleString mdl == moduleString localmdl
+ then ppName name
+ else ppFullQualName mdl name
+ RelativeQual localmdl ->
case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
- Just [] -> ppQualifyName NoQual name mdl
+ Just [] -> ppName name
-- sub-module, A.B.x -> B.x
Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
-- some module with same prefix, ABC.x -> ABC.x
- Just _ -> ppQualifyName FullQual name mdl
+ Just _ -> ppFullQualName mdl name
-- some other module, D.x -> D.x
- Nothing -> ppQualifyName FullQual name mdl
+ Nothing -> ppFullQualName mdl name
+ AliasedQual aliases localmdl ->
+ case (moduleString mdl == moduleString localmdl,
+ M.lookup mdl aliases) of
+ (False, Just alias) -> ppQualName alias name
+ _ -> ppName name
ppFullQualName :: Module -> Name -> Html
ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
+ppQualName :: ModuleName -> Name -> Html
+ppQualName mdlName name =
+ toHtml $ moduleNameString mdlName ++ '.' : getOccString name
ppName :: Name -> Html
ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index 7ba6d5f4..be1fcb9b 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils (
spliceURL,
groupId,
- (<+>), char, nonEmpty,
+ (<+>), char,
keyword, punctuate,
braces, brackets, pabrackets, parens, parenList, ubxParenList,
@@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc )
spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
where
file = fromMaybe "" maybe_file
mdl = case maybe_mod of
@@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
run ('%':'N':rest) = name ++ run rest
run ('%':'K':rest) = kind ++ run rest
run ('%':'L':rest) = line ++ run rest
- run ('%':'%':rest) = "%" ++ run rest
+ run ('%':'%':rest) = '%' : run rest
run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
@@ -119,15 +119,6 @@ char :: Char -> Html
char c = toHtml [c]
--- | Make an element that always has at least something (a non-breaking space)
--- If it would have otherwise been empty, then give it the class ".empty"
-nonEmpty :: (Html -> Html) -> Html -> Html
-nonEmpty el content_ =
- if isNoHtml content_
- then el ! [theclass "empty"] << spaceHtml
- else el << content_
-
-
quote :: Html -> Html
quote h = char '`' +++ h +++ '`'
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index c3d5d291..4bb46cba 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -28,13 +28,18 @@ import Data.Monoid
import Data.Ord
import Control.Applicative
import Control.Monad
-import qualified Data.Traversable as Traversable
+import qualified Data.Traversable as T
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
import GHC hiding (flags)
import HscTypes
import Name
import Bag
-import RdrName (GlobalRdrEnv)
+import RdrName
+import TcRnTypes
+import FastString (unpackFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -51,6 +56,8 @@ createInterface tm flags modMap instIfaceMap = do
instances = modInfoInstances mi
exportedNames = modInfoExports mi
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
+
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
(group_, mayExports, mayDocHeader) <-
@@ -60,23 +67,19 @@ createInterface tm flags modMap instIfaceMap = do
return (emptyRnGroup, Nothing, Nothing)
Just (x, _, y, z) -> return (x, y, z)
- -- The pattern-match should not fail, because createInterface is only
- -- done on loaded modules.
- Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
-
opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre safety mayDocHeader
+ (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
maps@(docMap, argMap, subMap, declMap) <-
- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+ liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
let exports0 = fmap (reverse . map unLoc) mayExports
exports
@@ -85,31 +88,33 @@ createInterface tm flags modMap instIfaceMap = do
liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
- exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
+ let warningMap = mkWarningMap warnings gre exportedNames
+ exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
instances instIfaceMap dflags
let visibleNames = mkVisibleNames exportItems opts
-- Measure haddock documentation coverage.
- let
- prunedExportItems0 = pruneExportItems exportItems
- haddockable = 1 + length exportItems -- module + exports
- haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
- coverage = (haddockable, haddocked)
+ let prunedExportItems0 = pruneExportItems exportItems
+ haddockable = 1 + length exportItems -- module + exports
+ haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+ coverage = (haddockable, haddocked)
-- Prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
- let
- prunedExportItems
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
+ let prunedExportItems
+ | OptPrune `elem` opts = prunedExportItems0
+ | otherwise = exportItems
+
+ let aliases =
+ mkAliasMap dflags $ tm_renamed_source tm
return Interface {
ifaceMod = mdl,
ifaceOrigFilename = msHsFilePath ms,
ifaceInfo = info,
- ifaceDoc = mbDoc,
- ifaceRnDoc = Nothing,
+ ifaceDoc = Documentation mbDoc (moduleWarning warnings),
+ ifaceRnDoc = Documentation Nothing Nothing,
ifaceOptions = opts,
ifaceDocMap = docMap,
ifaceArgMap = argMap,
@@ -121,10 +126,69 @@ createInterface tm flags modMap instIfaceMap = do
ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
ifaceSubMap = subMap,
+ ifaceModuleAliases = aliases,
ifaceInstances = instances,
ifaceHaddockCoverage = coverage
}
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
+ case mRenamedSource of
+ Nothing -> M.empty
+ Just (_,impDecls,_,_) ->
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn dflags
+ (fmap Module.fsToPackageId $
+ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+ DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+ Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+ flip Module.mkModule mdlName $
+ case filter snd $
+ Packages.lookupModuleInAllPackages dflags mdlName of
+ (pkgId,_):_ -> Packages.packageConfigId pkgId
+ [] -> Module.mainPackageId
+
+
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+type WarningMap = DocMap Name
+
+mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap NoWarnings _ _ = M.empty
+mkWarningMap (WarnAll _) _ _ = M.empty
+mkWarningMap (WarnSome ws) gre exps = M.fromList
+ [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+
+
+moduleWarning :: Warnings -> Maybe (Doc id)
+moduleWarning ws =
+ case ws of
+ NoWarnings -> Nothing
+ WarnSome _ -> Nothing
+ WarnAll w -> Just (warnToDoc w)
+
+
+warnToDoc :: WarningTxt -> Doc id
+warnToDoc w = case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " msg
+ (WarningTxt msg) -> format "Warning: " msg
+ where
+ format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs
+
-------------------------------------------------------------------------------
-- Doc options
@@ -154,50 +218,50 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
--- Declarations
+-- Maps
--------------------------------------------------------------------------------
type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
-mkMaps :: DynFlags -> GlobalRdrEnv -> [ClsInst] -> [Name] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps
-mkMaps dflags gre instances exports decls = do
- maps <- mapM f decls
- let mergeMaps (a,b,c,d) (x,y,z,w) =
- (M.unionWith mappend a x, M.unionWith mappend b y,
- M.unionWith mappend c z, M.unionWith mappend d w)
- let emptyMaps = (M.empty, M.empty, M.empty, M.empty)
- return (foldl' mergeMaps emptyMaps maps)
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
+mkMaps :: DynFlags
+ -> GlobalRdrEnv
+ -> [ClsInst]
+ -> [(LHsDecl Name, [HsDocString])]
+ -> ErrMsgM Maps
+mkMaps dflags gre instances decls = do
+ (a, b, c, d) <- unzip4 <$> mapM mappings decls
+ return (f a, f b, f c, f d)
where
+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith (<>) . concat
+
+ mappings (ldecl, docStrs) = do
+ let decl = unLoc ldecl
+ let declDoc strs m = do
+ doc <- processDocStrings dflags gre strs
+ m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
+ return (doc, m')
+ (doc, args) <- declDoc docStrs (typeDocs decl)
+ let subs = subordinates decl
+ (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
+ let ns = names decl
+ subNs = [ n | (n, _, _) <- subs ]
+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+ sm = [ (n, subNs) | n <- ns ]
+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+ return (dm, am, sm, cm)
+
+ instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
- f :: (LHsDecl Name, [HsDocString]) -> ErrMsgM Maps
- f (decl@(L _ d), docs) = do
- mayDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs
- argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs d) $
- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
-
- let subs_ = subordinates d
- let subs_' = filter (\(name, _, _) -> name `elem` exports) subs_
-
- (subDocs, subArgMap) <- unzip <$> (forM subs_' $ \(name, mbSubDocStr, subFnArgsDocStr) -> do
- mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr
- subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $
- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
- return ((name, mbSubDoc), (name, subFnArgsDoc)))
-
- let subNames = map fst subDocs
-
- let names = case d of
- InstD (ClsInstD { cid_poly_ty = L l _ }) -> maybeToList (M.lookup l instanceMap) -- See note [2].
- _ -> filter (`elem` exports) (getMainDeclBinder d)
-
- let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs))
- let argMap' = M.fromList [ (n, argDocs) | n <- names ] `mappend` M.fromList subArgMap
- let subMap' = M.fromList [ (n, subNames) | n <- names ]
- let dclMap' = M.fromList [ (n, [decl]) | n <- names ++ subNames ]
- return (docMap', argMap', subMap', dclMap')
-
+ names :: HsDecl Name -> [Name]
+ names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2].
+ names decl = getMainDeclBinder decl
-- Note [2]:
------------
@@ -208,6 +272,12 @@ mkMaps dflags gre instances exports decls = do
-- with InstDecls).
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates (TyClD decl)
| isClassDecl decl = classSubs
@@ -302,7 +372,7 @@ warnAboutFilteredDecls dflags mdl decls = do
tell [
"Warning: " ++ modStr ++ ": Instances of type and data "
++ "families are not yet supported. Instances of the following families "
- ++ "will be filtered out:\n " ++ concat (intersperse ", "
+ ++ "will be filtered out:\n " ++ (intercalate ", "
$ map (occNameString . nameOccName) typeInstances) ]
let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
@@ -311,7 +381,7 @@ warnAboutFilteredDecls dflags mdl decls = do
unless (null instances) $
tell [
"Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
- ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ]
+ ++ "These instances are affected:\n" ++ intercalate ", " instances ]
--------------------------------------------------------------------------------
@@ -323,7 +393,7 @@ warnAboutFilteredDecls dflags mdl decls = do
-- | Filter out declarations that we don't handle in Haddock
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls decls = filter (isHandled . unL . fst) decls
+filterDecls = filter (isHandled . unL . fst)
where
isHandled (ForD (ForeignImport {})) = True
isHandled (TyClD {}) = True
@@ -360,10 +430,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs ((L _ (DocD (DocCommentNext str))):ds)
+ go prev docs (L _ (DocD (DocCommentNext str)) : ds)
| Nothing <- prev = go Nothing (str:docs) ds
| Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds
+ go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
go Nothing docs (d:ds) = go (Just d) docs ds
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -379,6 +449,7 @@ collectDocs = go Nothing []
mkExportItems
:: IfaceMap
-> Module -- this module
+ -> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
-> [LHsDecl Name]
@@ -389,39 +460,31 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod gre exportedNames decls0
+ modMap thisMod warnings gre exportedNames decls0
(maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
case optExports of
- Nothing -> fullModuleContents dflags gre maps decls
- Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
+ Nothing -> fullModuleContents dflags warnings gre maps decls
+ Just exports -> liftM concat $ mapM lookupExport exports
where
decls = filter (not . isInstD . unLoc) decls0
- -- A type signature can have multiple names, like:
- -- foo, bar :: Types..
- -- When going throug the exported names we have to take care to detect such
- -- situations and remove the duplicates.
- commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =
- getMainDeclBinder sig1 == getMainDeclBinder sig2
- commaDeclared _ _ = False
-
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
lookupExport (IEGroup lev docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
+ ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
lookupExport (IEDoc docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ])
lookupExport (IEDocNamed str) = liftErrMsg $
ifDoc (findNamedDoc str [ unL d | d <- decls ])
(\docStr ->
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ]))
@@ -433,19 +496,12 @@ mkExportItems
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
- let mdl = nameModule t
- (doc, subs)
- | mdl == thisMod =
- exportDecl t docMap argMap subMap
- | Just iface <- M.lookup mdl modMap =
- exportDecl t (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)
- | otherwise = (noDocForDecl, []) in
case findDecl t of
- [L _ (ValD _)] -> do
+ ([L _ (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t doc
return [export]
- ds | decl : _ <- filter (not . isValD . unLoc) ds ->
+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
in case () of
_
@@ -456,7 +512,7 @@ mkExportItems
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
- | not $ t `elem` declNames,
+ | t `notElem` declNames,
Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
@@ -467,25 +523,24 @@ mkExportItems
return []
-- normal case
- | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ]
+ | otherwise -> return [ mkExportDecl t newDecl docs_ ]
where
- -- Since a single signature might refer to many names, we
- -- need to filter the ones that are actually exported. This
- -- requires modifying the type signatures to "hide" the
- -- names that are not exported.
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
newDecl = case decl of
(L loc (SigD sig)) ->
- L loc . SigD . fromJust $ filterSigNames isExported sig
+ L loc . SigD . fromJust $ filterSigNames (== t) sig
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
_ -> decl
-- Declaration from another package
- [] -> do
+ ([], _) -> do
mayDecl <- hiDecl dflags t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
- Just decl -> do
+ Just decl ->
-- We try to get the subs and docs
-- from the installed .haddock file for that package.
case M.lookup (nameModule t) instIfaceMap of
@@ -494,8 +549,8 @@ mkExportItems
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
return [ mkExportDecl t decl (noDocForDecl, subs_) ]
- Just iface -> do
- return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ Just iface ->
+ return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
@@ -512,13 +567,15 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> [LHsDecl Name]
- findDecl name
- | mdl == thisMod = maybe [] id (M.lookup name declMap)
- | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface))
- | otherwise = []
+ findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl n
+ | m == thisMod, Just ds <- M.lookup n declMap =
+ (ds, lookupDocs n warnings docMap argMap subMap)
+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+ (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+ | otherwise = ([], (noDocForDecl, []))
where
- mdl = nameModule name
+ m = nameModule n
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
@@ -539,12 +596,16 @@ hiValExportItem dflags name doc = do
Just decl -> return (ExportDecl decl doc [] [])
-exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-exportDecl name docMap argMap subMap =
- let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
- let doc = (M.lookup name docMap, lookupArgMap name) in
- let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
- (doc, subs)
+-- | Lookup docs for a declaration from maps.
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings docMap argMap subMap =
+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+ let doc = (lookupDoc n, lookupArgDoc n) in
+ let subs = M.findWithDefault [] n subMap in
+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+ (doc, subDocs)
+ where
+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
-- | Return all export items produced by an exported module. That is, we're
@@ -563,6 +624,7 @@ exportDecl name docMap argMap subMap =
moduleExports :: Module -- ^ Module A
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
+ -> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
-> [LHsDecl Name] -- ^ All the declarations in A
@@ -570,8 +632,8 @@ moduleExports :: Module -- ^ Module A
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps
- | m == thisMod = fullModuleContents dflags gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
+ | m == thisMod = fullModuleContents dflags warnings gre maps decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -609,25 +671,38 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
- liftM catMaybes $ mapM mkExportItem decls
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
+ liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ --
+ -- We go through the list of declarations and expand type signatures, so
+ -- that every type signature has exactly one name!
+ expandSig :: [LHsDecl name] -> [LHsDecl name]
+ expandSig = foldr f []
+ where
+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f x xs = x : xs
+
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
+ mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+ mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
return $ fmap ExportDoc mbDoc
mkExportItem (L _ (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
- let (doc, _) = exportDecl name docMap argMap subMap in
+ let (doc, _) = lookupDocs name warnings docMap argMap subMap in
fmap Just (hiValExportItem dflags name doc)
| otherwise = return Nothing
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
- let (doc, subs) = exportDecl name docMap argMap subMap in
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [])
| otherwise = return Nothing
@@ -687,11 +762,11 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- Pruning
+-- | Keep exprt items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
+pruneExportItems = filter hasDoc
where
- hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
@@ -709,12 +784,12 @@ mkVisibleNames exports opts
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name decls = search decls
+findNamedDoc name = search
where
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search ((DocD (DocCommentNamed name' doc)):rest)
+ search (DocD (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index c13e57be..d68f78f8 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+ -----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
-- Copyright : (c) Isaac Dupree 2009,
@@ -9,11 +9,10 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
- ( HaddockCommentType(..)
- , lexParseRnHaddockComment
- , lexParseRnHaddockCommentList
- , lexParseRnMbHaddockComment
- , lexParseRnHaddockModHeader
+ ( processDocString
+ , processDocStringParas
+ , processDocStrings
+ , processModuleHeader
) where
@@ -24,6 +23,7 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Doc
import Control.Applicative
+import Data.List
import Data.Maybe
import FastString
import GHC
@@ -33,62 +33,59 @@ import RdrName
import RnEnv
-data HaddockCommentType = NormalHaddockComment | DocSectionComment
-
-
-lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockCommentList dflags hty gre docStrs = do
- docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs
- let docs = catMaybes docMbs
- let doc = foldl docAppend DocEmpty docs
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+processDocStrings dflags gre strs = do
+ docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
+ let doc = foldl' docAppend DocEmpty docs
case doc of
DocEmpty -> return Nothing
_ -> return (Just doc)
-lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
- GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocString = process parseString
+
+process :: ([LToken] -> Maybe (Doc RdrName))
+ -> DynFlags
+ -> GlobalRdrEnv
+ -> HsDocString
+ -> ErrMsgM (Maybe (Doc Name))
+process parse dflags gre (HsDocString fs) = do
let str = unpackFS fs
- let toks = tokenise dflags str (0,0) -- TODO: real position
- let parse = case hty of
- NormalHaddockComment -> parseParas
- DocSectionComment -> parseString
+ let toks = tokenise dflags str (0,0) -- TODO: real position
case parse toks of
Nothing -> do
- tell ["doc comment parse failed: "++str]
+ tell [ "doc comment parse failed: " ++ str ]
return Nothing
Just doc -> return (Just (rename dflags gre doc))
-lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing
-lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d
-
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+ -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+ (hmi, doc) <-
+ case mayStr of
--- yes, you always get a HaddockModInfo though it might be empty
-lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> GhcDocHdr
- -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-lexParseRnHaddockModHeader dflags gre safety mbStr = do
- (hmi, docn) <-
- case mbStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
case parseModuleHeader dflags str of
- Left mess -> do
- tell ["haddock module header parse failed: " ++ mess]
+ Left msg -> do
+ tell ["haddock module header parse failed: " ++ msg]
return failure
- Right (info, doc) -> return (renameHmi dflags gre info, Just (rename dflags gre doc))
- return (hmi { hmi_safety = Just $ showPpr dflags safety }, docn)
+ Right (hmi, doc) -> do
+ let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
+ doc' = rename dflags gre doc
+ return (hmi', Just doc')
+ return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
where
failure = (emptyHaddockModInfo, Nothing)
-renameHmi :: DynFlags -> GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
-renameHmi dflags gre hmi = hmi { hmi_description = rename dflags gre <$> hmi_description hmi }
-
-
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
where
@@ -109,6 +106,7 @@ rename dflags gre = rn
a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
-- If an id can refer to multiple things, we give precedence to type
-- constructors.
+ DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
DocMonospaced doc -> DocMonospaced (rn doc)
DocUnorderedList docs -> DocUnorderedList (map rn docs)
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 35533d0d..411b6661 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -137,14 +137,14 @@ parseKey key toParse0 =
(spaces1,cs1) = extractLeadingSpaces cs
in
(c:spaces1,cs1)
- | True = ([],s)
+ | otherwise = ([],s)
extractNextLine :: String -> (String,String)
extractNextLine [] = ([],[])
extractNextLine (c:cs)
| c == '\n' =
([],cs)
- | True =
+ | otherwise =
let
(line,rest) = extractNextLine cs
in
@@ -156,5 +156,5 @@ parseKey key toParse0 =
extractPrefix _ [] = Nothing
extractPrefix (c1:cs1) (c2:cs2)
| toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
- | True = Nothing
+ | otherwise = Nothing
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 380147be..6109c341 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -12,18 +12,19 @@
module Haddock.Interface.Rename (renameInterface) where
-import Haddock.Types
import Haddock.GhcUtils
+import Haddock.Types
+import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
-import Bag (emptyBag)
+import Control.Applicative
+import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
-import Prelude hiding (mapM)
import Data.Traversable (mapM)
-import Control.Monad hiding (mapM)
+import Prelude hiding (mapM)
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
@@ -45,7 +46,7 @@ renameInterface dflags renamingEnv warnings iface =
(rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
(finalModuleDoc, missingNames4)
- = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface))
+ = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
-- combine the missing names and filter out the built-ins, which would
-- otherwise allways be missing.
@@ -92,6 +93,13 @@ instance Monad (GenRnM n) where
(>>=) = thenRn
return = returnRn
+instance Functor (GenRnM n) where
+ fmap f x = do a <- x; return (f a)
+
+instance Applicative (GenRnM n) where
+ pure = return
+ (<*>) = ap
+
returnRn :: a -> GenRnM n a
returnRn a = RnM (const (a,[]))
thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
@@ -137,15 +145,14 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
renameExportItems = mapM renameExportItem
-renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName)
-renameDocForDecl (mbDoc, fnArgsDoc) = do
- mbDoc' <- renameMaybeDoc mbDoc
- fnArgsDoc' <- renameFnArgsDoc fnArgsDoc
- return (mbDoc', fnArgsDoc')
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+ (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
-renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName))
-renameMaybeDoc = mapM renameDoc
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc mWarning) =
+ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
@@ -168,6 +175,9 @@ renameDoc d = case d of
return (DocIdentifier x')
DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
DocModule str -> return (DocModule str)
+ DocWarning doc -> do
+ doc' <- renameDoc doc
+ return (DocWarning doc')
DocEmphasis doc -> do
doc' <- renameDoc doc
return (DocEmphasis doc')
@@ -240,11 +250,11 @@ renameType t = case t of
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsOpTy a (w, (L loc op)) b -> do
+ HsOpTy a (w, L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (w, (L loc op')) b')
+ return (HsOpTy a' (w, L loc op') b')
HsParTy ty -> return . HsParTy =<< renameLType ty
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index fcf7fe65..970093df 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -22,24 +22,25 @@ module Haddock.InterfaceFile (
import Haddock.Types
import Haddock.Utils hiding (out)
-import Data.List
-import Data.Word
+import Control.Monad
import Data.Array
import Data.IORef
+import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Word
-import GHC hiding (NoLink)
-import Binary
import BinIface (getSymtabName, getDictFastString)
-import Name
-import UniqSupply
-import UniqFM
-import IfaceEnv
-import HscTypes
-import GhcMonad (withSession)
+import Binary
import FastMutInt
import FastString
+import GHC hiding (NoLink)
+import GhcMonad (withSession)
+import HscTypes
+import IfaceEnv
+import Name
+import UniqFM
+import UniqSupply
import Unique
@@ -65,13 +66,13 @@ binaryInterfaceMagic = 0xD0Cface
-- we version our interface files accordingly.
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
#elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
#elif __GLASGOW_HASKELL__ == 704
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
#elif __GLASGOW_HASKELL__ == 705
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 20
#else
#error Unknown GHC version
#endif
@@ -110,8 +111,8 @@ writeInterfaceFile filename iface = do
bin_dict_map = dict_map_ref }
-- put the main thing
- bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab)
- (putFastString bin_dict)
+ let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
+ (putFastString bin_dict)
put_ bh iface
-- write the symtab pointer at the front of the file
@@ -295,12 +296,9 @@ putSymbolTable bh next_off symtab = do
getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
getSymbolTable bh namecache = do
sz <- get bh
- od_names <- sequence (replicate sz (get bh))
- let
- arr = listArray (0,sz-1) names
- (namecache', names) =
- mapAccumR (fromOnDiskName arr) namecache od_names
- --
+ od_names <- replicateM sz (get bh)
+ let arr = listArray (0,sz-1) names
+ (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
return (namecache', arr)
@@ -469,6 +467,9 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocIdentifierUnchecked x) = do
putByte bh 16
put_ bh x
+ put_ bh (DocWarning ag) = do
+ putByte bh 17
+ put_ bh ag
get bh = do
h <- getByte bh
case h of
@@ -523,6 +524,9 @@ instance (Binary id) => Binary (Doc id) where
16 -> do
x <- get bh
return (DocIdentifierUnchecked x)
+ 17 -> do
+ ag <- get bh
+ return (DocWarning ag)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index f65aee8c..b9ebe688 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -34,6 +34,7 @@ import Data.Char
import Data.Word (Word8)
import Numeric
import System.IO.Unsafe
+import Debug.Trace
}
$ws = $white # \n
@@ -181,7 +182,7 @@ tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para i
go inp@(pos, _, str) sc =
case alexScan inp sc of
AlexEOF -> []
- AlexError _ -> error "lexical error"
+ AlexError _ -> []
AlexSkip inp' _ -> go inp' sc
AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 4e42fd32..46f9def7 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -126,7 +126,7 @@ options backwardsCompat =
Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
"page heading",
Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
- "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'",
+ "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
Option ['?'] ["help"] (NoArg Flag_Help)
"display this help and exit",
Option ['V'] ["version"] (NoArg Flag_Version)
@@ -229,13 +229,17 @@ optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-qualification :: [Flag] -> Qualification
+qualification :: [Flag] -> Either String QualOption
qualification flags =
case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
- "full":_ -> FullQual
- "local":_ -> LocalQual Nothing
- "relative":_ -> RelativeQual Nothing
- _ -> NoQual
+ [] -> Right OptNoQual
+ ["none"] -> Right OptNoQual
+ ["full"] -> Right OptFullQual
+ ["local"] -> Right OptLocalQual
+ ["relative"] -> Right OptRelativeQual
+ ["aliased"] -> Right OptAliasedQual
+ [arg] -> Left $ "unknown qualification type " ++ show arg
+ _:_ -> Left "qualification option given multiple times"
verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 20b1182b..3cadf33a 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -24,6 +24,7 @@ import Control.Exception
import Control.Arrow
import Data.Typeable
import Data.Map (Map)
+import Data.Maybe
import qualified Data.Map as Map
import Data.Monoid
import GHC hiding (NoLink)
@@ -42,7 +43,6 @@ type ArgMap a = Map Name (Map Int (Doc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type SrcMap = Map PackageId FilePath
-type GhcDocHdr = Maybe LHsDocString
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -68,10 +68,10 @@ data Interface = Interface
, ifaceInfo :: !(HaddockModInfo Name)
-- | Documentation header.
- , ifaceDoc :: !(Maybe (Doc Name))
+ , ifaceDoc :: !(Documentation Name)
-- | Documentation header with cross-reference information.
- , ifaceRnDoc :: Maybe (Doc DocName)
+ , ifaceRnDoc :: Documentation DocName
-- | Haddock options for this module (prune, ignore-exports, etc).
, ifaceOptions :: ![DocOption]
@@ -104,12 +104,15 @@ data Interface = Interface
-- module.
, ifaceVisibleExports :: ![Name]
+ -- | Aliases of module imports as in @import A.B.C as C@.
+ , ifaceModuleAliases :: AliasMap
+
-- | Instances exported by the module.
, ifaceInstances :: ![ClsInst]
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
- , ifaceHaddockCoverage :: (Int,Int)
+ , ifaceHaddockCoverage :: (Int,Int)
}
@@ -211,20 +214,30 @@ data ExportItem name
-- | A cross-reference to another module.
| ExportModule Module
+data Documentation name = Documentation
+ { documentationDoc :: Maybe (Doc name)
+ , documentationWarning :: Maybe (Doc name)
+ } deriving Functor
+
+
+combineDocumentation :: Documentation name -> Maybe (Doc name)
+combineDocumentation (Documentation Nothing Nothing) = Nothing
+combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)
+
-- | Arguments and result are indexed by Int, zero-based from the left,
-- because that's the easiest to use when recursing over types.
type FnArgsDoc name = Map Int (Doc name)
-type DocForDecl name = (Maybe (Doc name), FnArgsDoc name)
+type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
-noDocForDecl = (Nothing, Map.empty)
+noDocForDecl = (Documentation Nothing Nothing, Map.empty)
unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
-unrenameDocForDecl (mbDoc, fnArgsDoc) =
- (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc)
+unrenameDocForDecl (doc, fnArgsDoc) =
+ (fmap getName doc, (fmap . fmap) getName fnArgsDoc)
-----------------------------------------------------------------------------
@@ -283,6 +296,7 @@ data Doc id
| DocIdentifier id
| DocIdentifierUnchecked (ModuleName, OccName)
| DocModule String
+ | DocWarning (Doc id)
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
| DocUnorderedList [Doc id]
@@ -301,10 +315,6 @@ instance Monoid (Doc id) where
mappend = DocAppend
-unrenameDoc :: Doc DocName -> Doc Name
-unrenameDoc = fmap getName
-
-
data Example = Example
{ exampleExpression :: String
, exampleResult :: [String]
@@ -324,6 +334,7 @@ data DocMarkup id a = Markup
, markupIdentifier :: id -> a
, markupIdentifierUnchecked :: (ModuleName, OccName) -> a
, markupModule :: String -> a
+ , markupWarning :: a -> a
, markupEmphasis :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
@@ -373,12 +384,44 @@ data DocOption
-- | Option controlling how to qualify names
+data QualOption
+ = OptNoQual -- ^ Never qualify any names.
+ | OptFullQual -- ^ Qualify all names fully.
+ | OptLocalQual -- ^ Qualify all imported names fully.
+ | OptRelativeQual -- ^ Like local, but strip module prefix
+ -- from modules in the same hierarchy.
+ | OptAliasedQual -- ^ Uses aliases of module names
+ -- as suggested by module import renamings.
+ -- However, we are unfortunately not able
+ -- to maintain the original qualifications.
+ -- Image a re-export of a whole module,
+ -- how could the re-exported identifiers be qualified?
+
+type AliasMap = Map Module ModuleName
+
data Qualification
- = NoQual -- ^ Never qualify any names.
- | FullQual -- ^ Qualify all names fully.
- | LocalQual (Maybe Module) -- ^ Qualify all imported names fully.
- | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix.
- -- from modules in the same hierarchy.
+ = NoQual
+ | FullQual
+ | LocalQual Module
+ | RelativeQual Module
+ | AliasedQual AliasMap Module
+ -- ^ @Module@ contains the current module.
+ -- This way we can distinguish imported and local identifiers.
+
+makeContentsQual :: QualOption -> Qualification
+makeContentsQual qual =
+ case qual of
+ OptNoQual -> NoQual
+ _ -> FullQual
+
+makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
+makeModuleQual qual aliases mdl =
+ case qual of
+ OptLocalQual -> LocalQual mdl
+ OptRelativeQual -> RelativeQual mdl
+ OptAliasedQual -> AliasedQual aliases mdl
+ OptFullQual -> FullQual
+ OptNoQual -> NoQual
-----------------------------------------------------------------------------
@@ -429,7 +472,7 @@ throwE str = throw (HaddockException str)
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
-- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) }
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
--instance MonadIO ErrMsgGhc where
-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
--er, implementing GhcMonad involves annoying ExceptionMonad and
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 4114b1db..53e8bba8 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -70,7 +70,7 @@ import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
+import System.Exit
import System.IO ( hPutStr, stderr )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
@@ -162,11 +162,11 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
field_avail (ConDeclField n _ _) = unLoc n `elem` names
field_types flds = [ t | ConDeclField _ t _ <- flds ]
- keep _ | otherwise = Nothing
+ keep _ = Nothing
restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
-restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
@@ -298,7 +298,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
+bye s = putStr s >> exitSuccess
die :: String -> IO a
@@ -331,7 +331,6 @@ escapeStr = escapeURIString isUnreserved
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
-- (at least if you want to build network with haddock docs)
--- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
| p c = [c]
@@ -422,6 +421,7 @@ markup m (DocParagraph d) = markupParagraph m (markup m d)
markup m (DocIdentifier x) = markupIdentifier m x
markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
markup m (DocModule mod0) = markupModule m mod0
+markup m (DocWarning d) = markupWarning m (markup m d)
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
@@ -448,6 +448,7 @@ idMarkup = Markup {
markupIdentifier = DocIdentifier,
markupIdentifierUnchecked = DocIdentifierUnchecked,
markupModule = DocModule,
+ markupWarning = DocWarning,
markupEmphasis = DocEmphasis,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
diff --git a/src/Main.hs b/src/Main.hs
index b80c0e96..beb01b86 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -57,6 +57,7 @@ import Paths_haddock
import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
+import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
import Panic (panic, handleGhcException)
import Module
@@ -126,9 +127,13 @@ main :: IO ()
main = handleTopExceptions $ do
-- Parse command-line flags and handle some of them initially.
+ -- TODO: unify all of this (and some of what's in the 'render' function),
+ -- into one function that returns a record with a field for each option,
+ -- or which exits with an error or help message.
args <- getArgs
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
+ qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
libDir <- fmap snd (getGhcDirs flags)
@@ -151,7 +156,7 @@ main = handleTopExceptions $ do
Nothing -> return ()
-- Render the interfaces.
- liftIO $ renderStep dflags flags packages ifaces
+ liftIO $ renderStep dflags flags qual packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -161,7 +166,7 @@ main = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags flags packages []
+ liftIO $ renderStep dflags flags qual packages []
readPackagesAndProcessModules :: [Flag] -> [String]
@@ -177,19 +182,19 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: DynFlags -> [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags qual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
- render dflags flags interfaces installedIfaces srcMap
+ render dflags flags qual interfaces installedIfaces srcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags qual ifaces installedIfaces srcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -200,7 +205,6 @@ render dflags flags ifaces installedIfaces srcMap = do
opt_index_url = optIndexUrl flags
odir = outputDir flags
opt_latex_style = optLaTeXStyle flags
- opt_qualification = qualification flags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -230,14 +234,15 @@ render dflags flags ifaces installedIfaces srcMap = do
when (Flag_GenContents `elem` flags) $ do
ppHtmlContents odir title pkgStr
themes opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty opt_qualification
+ allVisibleIfaces True prologue pretty
+ (makeContentsQual qual)
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
ppHtml title pkgStr visibleIfaces odir
prologue
themes sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode opt_qualification
+ opt_contents_url opt_index_url unicode qual
pretty
copyHtmlBits odir libDir themes
@@ -292,7 +297,7 @@ dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile
-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking. Then run the given 'Ghc' action.
withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc libDir flags ghcActs = do
+withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
-- TODO: handle warnings?
(restFlags, _) <- parseStaticFlags (map noLoc flags)
runGhc (Just libDir) $ do
@@ -310,6 +315,7 @@ withGhc libDir flags ghcActs = do
-- dynamic or static linking at all!
_ <- setSessionDynFlags dynflags'''
ghcActs dynflags'''
+ `finally` restoreStaticFlagGlobals savedFlags
where
parseGhcFlags :: Monad m => DynFlags -> [Located String]
-> [String] -> m DynFlags
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 11:46:43 +0000