haddock-api 2.19.0.1 → 2.20.0
raw patch · 17 files changed
+431/−313 lines, 17 filesdep ~Cabaldep ~ghcdep ~haddock-libraryPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Cabal, ghc, haddock-library
API changes (from Hackage documentation)
+ Documentation.Haddock: Flag_SinceQualification :: String -> Flag
- Documentation.Haddock: type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))
+ Documentation.Haddock: type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module)
Files
- haddock-api.cabal +6/−6
- src/Haddock.hs +60/−55
- src/Haddock/Backends/LaTeX.hs +2/−2
- src/Haddock/Backends/Xhtml.hs +57/−53
- src/Haddock/Backends/Xhtml/Decl.hs +87/−78
- src/Haddock/Backends/Xhtml/DocMarkup.hs +29/−21
- src/Haddock/Backends/Xhtml/Layout.hs +36/−33
- src/Haddock/Interface.hs +14/−7
- src/Haddock/Interface/AttachInstances.hs +13/−5
- src/Haddock/Interface/Create.hs +57/−30
- src/Haddock/Interface/LexParseRn.hs +11/−10
- src/Haddock/Interface/ParseModuleHeader.hs +3/−3
- src/Haddock/Interface/Rename.hs +2/−2
- src/Haddock/InterfaceFile.hs +8/−3
- src/Haddock/Options.hs +37/−2
- src/Haddock/Parser.hs +2/−2
- src/Haddock/Types.hs +7/−1
haddock-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api-version: 2.19.0.1+version: 2.20.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -42,9 +42,9 @@ -- this package typically supports only single major versions build-depends: base ^>= 4.11.0 , Cabal ^>= 2.2.0- , ghc ^>= 8.4+ , ghc ^>= 8.4.2 , ghc-paths ^>= 0.1.0.9- , haddock-library ^>= 1.5.0+ , haddock-library ^>= 1.6.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by@@ -166,10 +166,10 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.0.0- , ghc ^>= 8.4+ build-depends: Cabal ^>= 2.2.0+ , ghc ^>= 8.4.2 , ghc-paths ^>= 0.1.0.9- , haddock-library ^>= 1.5.0+ , haddock-library ^>= 1.6.0 , xhtml ^>= 3000.2.2 , hspec ^>= 2.4.4 , QuickCheck ^>= 2.11
src/Haddock.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- |@@ -25,7 +25,6 @@ withGhc ) where -import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes)@@ -42,7 +41,6 @@ import Haddock.Utils import Control.Monad hiding (forM_)-import Control.Applicative import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf)@@ -151,7 +149,8 @@ -- or which exits with an error or help message. (flags, files) <- parseHaddockOpts args shortcutFlags flags- qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}+ qual <- rightOrThrowE (qualification flags)+ sinceQual <- rightOrThrowE (sinceQualification flags) -- inject dynamic-too into flags before we proceed flags' <- ghc flags $ do@@ -184,7 +183,7 @@ } -- Render the interfaces.- liftIO $ renderStep dflags flags qual packages ifaces+ liftIO $ renderStep dflags flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $@@ -194,7 +193,7 @@ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) -- Render even though there are no input files (usually contents/index).- liftIO $ renderStep dflags flags qual packages []+ liftIO $ renderStep dflags flags sinceQual qual packages [] -- | Create warnings about potential misuse of -optghc warnings :: [String] -> [String]@@ -228,8 +227,9 @@ return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()-renderStep dflags flags qual pkgs interfaces = do+renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption+ -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+renderStep dflags flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs@@ -238,12 +238,12 @@ ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path)- render dflags flags qual interfaces installedIfaces extSrcMap-+ render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags.-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()-render dflags flags qual ifaces installedIfaces extSrcMap = do+render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]+ -> [InstalledInterface] -> Map Module FilePath -> IO ()+render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags)@@ -270,6 +270,10 @@ pkgKey = moduleUnitId pkgMod pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)+ sincePkg = case sinceQual of+ External -> pkgName+ Always -> Nothing (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -323,24 +327,34 @@ let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do- ppHtmlIndex odir title pkgStr- themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls- allVisibleIfaces pretty+ withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do+ _ <- {-# SCC ppHtmlIndex #-}+ ppHtmlIndex odir title pkgStr+ themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls+ allVisibleIfaces pretty+ return ()+ copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do- ppHtmlContents dflags' odir title pkgStr- themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls- allVisibleIfaces True prologue pretty- (makeContentsQual qual)+ withTiming (pure dflags') "ppHtmlContents" (const ()) $ do+ _ <- {-# SCC ppHtmlContents #-}+ ppHtmlContents dflags' odir title pkgStr+ themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls+ allVisibleIfaces True prologue pretty+ sincePkg (makeContentsQual qual)+ return () copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do- ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir- prologue- themes opt_mathjax sourceUrls' opt_wiki_urls- opt_contents_url opt_index_url unicode qual- pretty withQuickjump+ withTiming (pure dflags') "ppHtml" (const ()) $ do+ _ <- {-# SCC ppHtml #-}+ ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir+ prologue+ themes opt_mathjax sourceUrls' opt_wiki_urls+ opt_contents_url opt_index_url unicode sincePkg qual+ pretty withQuickjump+ return () copyHtmlBits odir libDir themes withQuickjump writeHaddockMeta odir withQuickjump @@ -348,7 +362,12 @@ -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do case pkgNameVer of- Nothing -> putStrLn . unlines $+ (Just (PackageName pkgNameFS), Just pkgVer) ->+ let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title+ | otherwise = unpackFS pkgNameFS+ in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)+ visibleIfaces odir+ _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." , ""@@ -356,38 +375,19 @@ ++ " using the --package-name" , " and --package-version arguments." ]- Just (PackageName pkgNameFS, pkgVer) ->- let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title- | otherwise = unpackFS pkgNameFS- in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)- visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do- ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style- libDir+ withTiming (pure dflags') "ppLatex" (const ()) $ do+ _ <- {-# SCC ppLatex #-}+ ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style+ libDir+ return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do- ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces---- | From GHC 7.10, this function has a potential to crash with a--- nasty message such as @expectJust getPackageDetails@ because--- package name and versions can no longer reliably be extracted in--- all cases: if the package is not installed yet then this info is no--- longer available. The @--package-name@ and @--package-version@--- Haddock flags allow the user to specify this information and it is--- returned here if present: if it is not present, the error will--- occur. Nasty but that's how it is for now. Potential TODO.-modulePackageInfo :: DynFlags- -> [Flag] -- ^ Haddock flags are checked as they may- -- contain the package name or version- -- provided by the user which we- -- prioritise- -> Module -> Maybe (PackageName, Data.Version.Version)-modulePackageInfo dflags flags modu =- cmdline <|> pkgDb- where- cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags- pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)+ withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do+ _ <- {-# SCC ppHyperlinkedSource #-}+ ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces+ return () -------------------------------------------------------------------------------@@ -400,7 +400,7 @@ -> [(DocPaths, FilePath)] -> m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs = do- catMaybes `liftM` mapM tryReadIface pairs+ catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't tryReadIface (paths, file) =@@ -609,8 +609,13 @@ h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle- return . Just $! parseParas dflags str+ return . Just $! parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options"+++rightOrThrowE :: Either String b -> IO b+rightOrThrowE (Left msg) = throwE msg+rightOrThrowE (Right x) = pure x #ifdef IN_GHC_TREE
src/Haddock/Backends/LaTeX.hs view
@@ -530,14 +530,14 @@ (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a)-isUndocdInstance (i,Nothing,_) = Just i+isUndocdInstance (i,Nothing,_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX-ppDocInstance unicode (instHead, doc, _) =+ppDocInstance unicode (instHead, doc, _, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
src/Haddock/Backends/Xhtml.hs view
@@ -70,6 +70,7 @@ -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode)+ -> Maybe String -- ^ Package name -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index@@ -78,7 +79,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode- qual debug withQuickjump = do+ pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i@@ -88,7 +89,7 @@ themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents- prologue debug (makeContentsQual qual)+ prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package@@ -96,12 +97,12 @@ (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual visible_ifaces mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces+ maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()@@ -258,11 +259,12 @@ -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool+ -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces@@ -276,41 +278,41 @@ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [- ppPrologue qual doctitle prologue,- ppSignatureTree qual sig_tree,- ppModuleTree qual tree+ ppPrologue pkg qual doctitle prologue,+ ppSignatureTree pkg qual sig_tree,+ ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) -ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html-ppPrologue _ _ Nothing = noHtml-ppPrologue qual title (Just doc) =- divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))+ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html+ppPrologue _ _ _ Nothing = noHtml+ppPrologue pkg qual title (Just doc) =+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) -ppSignatureTree :: Qualification -> [ModuleTree] -> Html-ppSignatureTree qual ts =- divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)+ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html+ppSignatureTree pkg qual ts =+ divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) -ppModuleTree :: Qualification -> [ModuleTree] -> Html-ppModuleTree _ [] = mempty-ppModuleTree qual ts =- divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)+ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html+ppModuleTree _ _ [] = mempty+ppModuleTree pkg qual ts =+ divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts) -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html-mkNodeList qual ss p ts = case ts of+mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html+mkNodeList pkg qual ss p ts = case ts of [] -> noHtml- _ -> unordList (zipWith (mkNode qual ss) ps ts)+ _ -> unordList (zipWith (mkNode pkg qual ss) ps ts) where ps = [ p ++ '.' : show i | i <- [(1::Int)..]] -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html-mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =+mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html+mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of@@ -330,14 +332,14 @@ Nothing -> toHtml s ) - shortDescr = maybe noHtml (origDocToHtml qual) short+ shortDescr = maybe noHtml (origDocToHtml pkg qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = if null ts then noHtml else collapseDetails p DetailsOpen ( thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++- mkNodeList qual (s:ss) p ts+ mkNodeList pkg qual (s:ss) p ts ) @@ -350,10 +352,11 @@ -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) -> Bool+ -> Maybe Package -> QualOption -> [Interface] -> IO ()-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do createDirectoryIfMissing True odir IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do Builder.hPutBuilder h (encodeToBuilder modules)@@ -371,7 +374,7 @@ goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] goExport mdl qual item- | Just item_html <- processExport True links_info unicode qual item+ | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) , "name" .= String (intercalate " " (map nameString names))@@ -529,11 +532,11 @@ ppHtmlModule :: FilePath -> String -> Themes -> Maybe String -> SourceURLs -> WikiURLs- -> Maybe String -> Maybe String -> Bool -> QualOption+ -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode qual debug iface = do+ maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface@@ -555,7 +558,7 @@ maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] createDirectoryIfMissing True odir@@ -565,9 +568,9 @@ signatureDocURL = "https://wiki.haskell.org/Module_signature" -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual- = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) ++++ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual+ = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans)@@ -585,7 +588,7 @@ description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc- where doc = docSection Nothing qual (ifaceRnDoc iface)+ where doc = docSection Nothing pkg qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis@@ -595,7 +598,7 @@ collapseDetails "syn" DetailsClosed ( thesummary << "Synopsis" +++ shortDeclList (- mapMaybe (processExport True linksInfo unicode qual) exports+ mapMaybe (processExport True linksInfo unicode pkg qual) exports ) ! collapseToggle "syn" "" ) @@ -609,19 +612,20 @@ bdy = foldr (+++) noHtml $- mapMaybe (processExport False linksInfo unicode qual) exports+ mapMaybe (processExport False linksInfo unicode pkg qual) exports orphans =- ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual+ ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual linksInfo = (maybe_source_url, maybe_wiki_url) -ppModuleContents :: Qualification+ppModuleContents :: Maybe Package -- ^ This package+ -> Qualification -> [ExportItem DocNameI]- -> Bool -- ^ Orphans sections+ -> Bool -- ^ Orphans sections -> Html-ppModuleContents qual exports orphan+ppModuleContents pkg qual exports orphan | null sections && not orphan = noHtml | otherwise = contentsDiv where@@ -641,7 +645,7 @@ | otherwise = ( html:secs, rest2 ) where html = linkedAnchor (groupId id0)- << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs+ << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest@@ -661,22 +665,22 @@ = other : go n es -processExport :: Bool -> LinksInfo -> Bool -> Qualification+processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances-processExport summary _ _ qual (ExportGroup lev id0 doc)- = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)-processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)- = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual-processExport summary _ _ qual (ExportNoDecl y [])+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)+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 []) = processDeclOneLiner summary $ ppDocName qual Prefix True y-processExport summary _ _ qual (ExportNoDecl y subs)+processExport summary _ _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs)-processExport summary _ _ qual (ExportDoc doc)- = nothingIf summary $ docSection_ Nothing qual doc-processExport summary _ _ _ (ExportModule mdl)+processExport summary _ _ pkg qual (ExportDoc doc)+ = nothingIf summary $ docSection_ Nothing pkg qual doc+processExport summary _ _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -43,17 +43,18 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]- -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html-ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode+ -> Maybe Package -> Qualification -> Html+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames- (hsSigWcType lty) fixities splice unicode qual+ (hsSigWcType lty) fixities splice unicode pkg qual SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames- ty fixities splice unicode qual- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual+ ty fixities splice unicode pkg qual+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ -> noHtml DerivD _ -> noHtml _ -> error "declaration not supported by ppDecl"@@ -61,28 +62,29 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->- Splice -> Unicode -> Qualification -> Html-ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =+ 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- splice unicode qual+ splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->- Splice -> Unicode -> Qualification -> Html-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =+ 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)- splice unicode qual HideEmptyContexts+ splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->- Splice -> Unicode -> Qualification -> Html-ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual+ Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice+ unicode pkg qual | summary = pref1 | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)- +++ docSection Nothing qual doc+ +++ docSection Nothing pkg qual doc where pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames@@ -92,15 +94,15 @@ ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->- Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html+ Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)- splice unicode qual emptyCtxts =+ splice unicode pkg qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode )- splice unicode qual emptyCtxts+ splice unicode pkg qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html@@ -110,12 +112,14 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (Html, Html, Html)- -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts+ -> Splice -> Unicode -> Maybe Package -> Qualification+ -> HideEmptyContexts -> Html+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)+ splice unicode pkg qual emptyCtxts | summary = pref1- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++- subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc+ subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc where curName = getName <$> listToMaybe docnames argDoc n = Map.lookup n argDocs@@ -181,23 +185,23 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)]- -> Splice -> Unicode -> Qualification -> Html+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities- splice unicode qual- = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual-ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"+ splice unicode pkg qual+ = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual+ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI- -> Splice -> Unicode -> Qualification -> Html+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype })- splice unicode qual+ splice unicode pkg qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)- splice unicode qual ShowEmptyToplevelContexts+ splice unicode pkg qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))@@ -206,7 +210,7 @@ fixs | summary = noHtml | otherwise = ppFixities fixities qual-ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"+ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html@@ -297,11 +301,13 @@ ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->- FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html-ppTyFam summary associated links instances fixities loc doc decl splice unicode qual+ FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->+ Qualification -> Html+ppTyFam summary associated links instances fixities loc doc decl splice unicode+ pkg qual | summary = ppTyFamHeader True associated decl unicode qual- | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl@@ -312,10 +318,10 @@ instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary- = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns+ = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise- = ppInstances links (OriginFamily docname) instances splice unicode qual+ = ppInstances links (OriginFamily docname) instances splice unicode pkg qual -- Individual equation of a closed type family ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl@@ -343,9 +349,10 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI- -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppAssocType summ links doc (L loc decl) fixities splice unicode qual =- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package+ -> Qualification -> Html+ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual --------------------------------------------------------------------------------@@ -454,22 +461,22 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)]- -> Splice -> Unicode -> Qualification -> Html+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc- subdocs splice unicode qual =+ subdocs splice unicode pkg qual = if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False (- [ ppAssocType summary links doc at [] splice unicode qual | at <- ats+ [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names (hsSigWcType typ)- [] splice unicode qual+ [] splice unicode pkg qual | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ]@@ -480,20 +487,20 @@ where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname-ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI- -> Splice -> Unicode -> Qualification -> Html+ -> 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 })- splice unicode qual- | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual- | otherwise = classheader +++ docSection Nothing qual d+ splice unicode pkg qual+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual+ | otherwise = classheader +++ docSection Nothing pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where sigs = map unLoc lsigs@@ -510,14 +517,14 @@ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- ToDo: add assocatied typ defaults- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual+ 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] (hsSigType typ)- subfixs splice unicode qual+ subfixs splice unicode pkg qual | L _ (ClassOpSig _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs@@ -551,38 +558,38 @@ ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances links (OriginClass nm) instances- splice unicode qual+ splice unicode pkg qual -ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo -> InstOrigin DocName -> [DocInstance DocNameI]- -> Splice -> Unicode -> Qualification+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html-ppInstances links origin instances splice unicode qual- = subInstances qual instName links True (zipWith instDecl [1..] instances)+ppInstances links origin instances splice unicode pkg qual+ = subInstances pkg qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString origin instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)- instDecl no (inst, mdoc, loc) =- ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)+ instDecl no (inst, mdoc, loc, mdl) =+ ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc) ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI]- -> Splice -> Unicode -> Qualification+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html-ppOrphanInstances links instances splice unicode qual- = subOrphanInstances qual links True (zipWith instDecl [1..] instances)+ppOrphanInstances links instances splice unicode pkg qual+ = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances) where instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)- instDecl no (inst, mdoc, loc) =- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)+ instDecl no (inst, mdoc, loc, mdl) =+ ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification@@ -591,13 +598,14 @@ -> Bool -- ^ Is instance orphan -> Int -- ^ Normal -> InstHead DocNameI+ -> Maybe Module -> SubDecl-ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc- , [subInstDetails iid ats sigs]+ , [subInstDetails iid ats sigs mname] ) where sigs = ppInstanceSigs links splice unicode qual clsiSigs@@ -605,7 +613,7 @@ TypeInst rhs -> ( subInstHead iid ptype , mdoc- , [subFamInstDetails iid prhs]+ , [subFamInstDetails iid prhs mname] ) where ptype = keyword "type" <+> typ@@ -614,11 +622,12 @@ DataInst dd -> ( subInstHead iid pdata , mdoc- , [subFamInstDetails iid pdecl])+ , [subFamInstDetails iid pdecl mname]) where pdata = keyword "data" <+> typ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where+ mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual @@ -711,12 +720,12 @@ [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] ->- Splice -> Unicode -> Qualification -> Html+ Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats- splice unicode qual+ splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit+ | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl@@ -736,14 +745,14 @@ | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" - constrBit = subConstructors qual- [ ppSideBySideConstr subdocs subfixs unicode qual c+ constrBit = subConstructors pkg qual+ [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc (getConNames (unLoc c)))) fixities ] - patternBit = subPatterns qual+ patternBit = subPatterns pkg qual [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode@@ -755,7 +764,7 @@ ] instancesBit = ppInstances links (OriginData docname) instances- splice unicode qual+ splice unicode pkg qual @@ -822,8 +831,8 @@ | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]- -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl-ppSideBySideConstr subdocs fixities unicode qual (L _ con)+ -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl+ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con of@@ -849,7 +858,7 @@ RecCon (L _ fields) -> [doRecordFields fields] _ -> [] - doRecordFields fields = subFields qual+ doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doGADTCon :: Located (HsType DocNameI) -> Html
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -171,10 +171,10 @@ -- 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 -> Hack (ModuleName, OccName) id -> Html-hackMarkup fmt' h' =+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html+hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h'- in html +++ renderMeta fmt' (metaConcat ms)+ in html +++ renderMeta fmt' currPkg (metaConcat ms) where hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> (Html, [Meta])@@ -193,45 +193,50 @@ (y, m') = hackMarkup' fmt d' in (markupAppend fmt x y, m ++ m') -renderMeta :: DocMarkup id Html -> Meta -> Html-renderMeta fmt (Meta { _version = Just x }) =+renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html+renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) = markupParagraph fmt . markupEmphasis fmt . toHtml $- "Since: " ++ formatVersion x+ "Since: " ++ formatPkgMaybe pkg ++ formatVersion x where formatVersion v = concat . intersperse "." $ map show v-renderMeta _ _ = noHtml+ formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"+ formatPkgMaybe _ = ""+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+ -> Maybe Package -- this package -> Maybe String -> MDoc id -> Html-markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten+markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply?-docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See- -- comments on 'toHack' for details.+docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See+ -- comments on 'toHack' for details.+ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html-docToHtml n qual = markupHacked fmt n . cleanup+docToHtml n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements.-docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'+docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'+ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html-docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup+docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> MDoc Name -> Html-origDocToHtml qual = markupHacked fmt Nothing . cleanup+origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html+origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> MDoc RdrName -> Html-rdrDocToHtml qual = markupHacked fmt Nothing . cleanup+rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html+rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -243,14 +248,17 @@ docSection :: Maybe Name -- ^ Name of the thing this doc is for+ -> Maybe Package -- ^ Current package -> Qualification -> Documentation DocName -> Html-docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation+docSection n pkg qual =+ maybe noHtml (docSection_ n pkg qual) . combineDocumentation -docSection_ :: Maybe Name -- ^ Name of the thing this doc is for+docSection_ :: Maybe Name -- ^ Name of the thing this doc is for+ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html-docSection_ n qual =- (docElement thediv <<) . docToHtml (getOccString <$> n) qual+docSection_ n pkg qual =+ (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual cleanup :: MDoc a -> MDoc a
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -47,7 +47,7 @@ import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map-import Text.XHtml hiding ( name, title, p, quote )+import Text.XHtml hiding ( name, title, quote ) import FastString ( unpackFS ) import GHC@@ -128,38 +128,39 @@ subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: Qualification -> [SubDecl] -> Maybe Html-subDlist _ [] = Nothing-subDlist qual decls = Just $ ulist << map subEntry decls+subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html+subDlist _ _ [] = Nothing+subDlist pkg qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = li << (define ! [theclass "src"] << decl +++- docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))+ docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs)) -subTable :: Qualification -> [SubDecl] -> Maybe Html-subTable _ [] = Nothing-subTable qual decls = Just $ table << aboves (concatMap subRow decls)+subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html+subTable _ _ [] = Nothing+subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <->- docElement td << fmap (docToHtml Nothing qual) mdoc)+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc) : map (cell . (td <<)) subs -- | Sub table with source information (optional).-subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html-subTableSrc _ _ _ [] = Nothing-subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)+subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool+ -> [(SubDecl,Located DocName)] -> Maybe Html+subTableSrc _ _ _ _ [] = Nothing+subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where subRow ((decl, mdoc, subs),L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc dn <->- docElement td << fmap (docToHtml Nothing qual) mdoc+ docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn@@ -170,49 +171,49 @@ subBlock hs = Just $ toHtml hs -subArguments :: Qualification -> [SubDecl] -> Html-subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual+subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html+subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: Qualification -> [SubDecl] -> Html-subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual+subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html+subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual -subPatterns :: Qualification -> [SubDecl] -> Html-subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual+subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html+subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual -subFields :: Qualification -> [SubDecl] -> Html-subFields qual = divSubDecls "fields" "Fields" . subDlist qual+subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html+subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual -subEquations :: Qualification -> [SubDecl] -> Html-subEquations qual = divSubDecls "equations" "Equations" . subTable qual+subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html+subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual -- | Generate sub table for instance declarations, with source-subInstances :: Qualification+subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html-subInstances qual nm lnks splice = maybe noHtml wrap . instTable+subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))- instTable = subTableSrc qual lnks splice+ instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm -subOrphanInstances :: Qualification+subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html-subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable+subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++)- instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice+ instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId $ "orphans" @@ -228,15 +229,17 @@ subInstDetails :: String -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents -> [Html] -- ^ Method contents (pretty-printed signatures)+ -> Html -- ^ Source module -> Html-subInstDetails iid ats mets =- subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)+subInstDetails iid ats mets mdl =+ subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance+ -> Html -- ^ Source module TODO: use this -> Html-subFamInstDetails iid fi =- subInstSection iid << thediv ! [theclass "src"] << fi+subFamInstDetails iid fi mdl =+ subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html
src/Haddock/Interface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface@@ -60,6 +60,7 @@ import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env) import RdrName (plusGlobalRdrEnv)+import ErrUtils (withTiming) #if defined(mingw32_HOST_OS) import System.IO@@ -93,13 +94,15 @@ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..."- interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap+ interfaces' <- {-# SCC attachInstances #-}+ withTiming getDynFlags "attachInstances" (const ()) $ do+ attachInstances (exportedNames, mods) interfaces instIfaceMap out verbosity verbose "Building cross-linking environment..." -- Combine the link envs of the external packages into one let extLinks = Map.unions (map ifLinkEnv extIfaces)- homeLinks = buildHomeLinks interfaces -- Build the environment for the home- -- package+ homeLinks = buildHomeLinks interfaces' -- Build the environment for the home+ -- package links = homeLinks `Map.union` extLinks out verbosity verbose "Renaming interfaces..."@@ -155,7 +158,9 @@ return (reverse ifaces) where f (ifaces, ifaceMap) modSummary = do- x <- processModule verbosity modSummary flags ifaceMap instIfaceMap+ x <- {-# SCC processModule #-}+ withTiming getDynFlags "processModule" (const ()) $ do+ processModule verbosity modSummary flags ifaceMap instIfaceMap return $ case x of Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.@@ -164,7 +169,7 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."- tm <- loadModule =<< typecheckModule =<< parseModule modsum+ tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum -- We need to modify the interactive context's environment so that when -- Haddock later looks for instances, it also looks in the modules it@@ -179,7 +184,9 @@ if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..."- (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap+ (interface, msg) <- {-# SCC createIterface #-}+ withTiming getDynFlags "createInterface" (const ()) $ do+ runWriterGhc $ createInterface tm flags modMap instIfaceMap liftIO $ mapM_ putStrLn msg dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface
src/Haddock/Interface/AttachInstances.hs view
@@ -69,7 +69,7 @@ attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))+ [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys@@ -91,7 +91,11 @@ let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst fam_instances = maybeToList mb_instances >>= snd- fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )+ fam_insts = [ ( synifyFamInst i opaque+ , doc+ , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))+ , nameModule_maybe n+ ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap@@ -99,14 +103,18 @@ , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ]- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))+ cls_insts = [ ( synifyInstHead i+ , instLookup instDocMap n iface ifaceMap instIfaceMap+ , spanName n (synifyInstHead i) (L eSpan (tcdName d))+ , nameModule_maybe n+ ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out- cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]- famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]+ cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]+ famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text
src/Haddock/Interface/Create.hs view
@@ -46,7 +46,6 @@ import Avail hiding (avail) import qualified Avail-import qualified Packages import qualified Module import qualified SrcLoc import ConLike (ConLike(..))@@ -55,13 +54,14 @@ import Name import NameSet import NameEnv+import Packages ( lookupModuleInAllPackages, PackageName(..) ) import Bag import RdrName import TcRnTypes-import FastString (concatFS)+import FastString ( concatFS, unpackFS ) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O-import HsDecls ( getConDetails )+import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'.@@ -85,12 +85,22 @@ !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi+ (pkgNameFS, _) = modulePackageInfo dflags flags mdl+ pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings , tcg_exports = all_exports }, md) = tm_internals_ tm + -- The 'pkgName' is necessary to decide what package to mention in "@since"+ -- annotations. Not having it is not fatal though.+ --+ -- Cabal can be trusted to pass the right flags, so this warning should be+ -- mostly encountered when running Haddock outside of Cabal.+ when (isNothing pkgName) $+ liftErrMsg $ tell [ "Warning: Package name is not available." ]+ -- The renamed source should always be available to us, but it's best -- to be on the safe side. (group_, imports, mayExports, mayDocHeader) <-@@ -103,7 +113,7 @@ opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation.- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader let declsWithDocs = topDecls group_ @@ -130,13 +140,13 @@ warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) maps@(!docMap, !argMap, !declMap, _) <-- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)+ liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module.- exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre+ exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre exportedNames decls maps fixMap unrestrictedImportedMods splices exports all_exports instIfaceMap dflags @@ -190,6 +200,7 @@ , ifaceTokenizedSrc = tokenizedSrc } + -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This@@ -266,7 +277,7 @@ lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName =- case Packages.lookupModuleInAllPackages dflags mdlName of+ case lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnitId mdlName @@ -346,11 +357,12 @@ -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags+ -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] -> [(LHsDecl GhcRn, [HsDocString])] -> ErrMsgM Maps-mkMaps dflags gre instances decls = do+mkMaps dflags pkgName gre instances decls = do (a, b, c) <- unzip3 <$> traverse mappings decls pure ( f' (map (nubByName fst) a) , f (filterMapping (not . M.null) b)@@ -377,8 +389,8 @@ declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do- doc' <- processDocStrings dflags gre strs- m' <- traverse (processDocStringParas dflags gre) m+ doc' <- processDocStrings dflags pkgName gre strs+ m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') (doc, args) <- declDoc docStrs (typeDocs decl)@@ -605,12 +617,13 @@ mkExportItems :: Bool -- is it a signature -> IfaceMap+ -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig)- -> [LHsDecl GhcRn] -- renamed source declarations+ -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap -> M.Map ModuleName [ModuleName]@@ -621,12 +634,12 @@ -> DynFlags -> ErrMsgGhc [ExportItem GhcRn] mkExportItems- is_sig modMap thisMod semMod warnings gre exportedNames decls+ is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports instIfaceMap dflags = case exportList of Nothing ->- fullModuleContents is_sig modMap thisMod semMod warnings gre+ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports@@ -636,14 +649,14 @@ return [ExportGroup lev "" doc] lookupExport (IEDoc docStr, _) = liftErrMsg $ do- doc <- processDocStringParas dflags gre docStr+ doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEDocNamed str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do- doc <- processDocStringParas dflags gre docStr+ doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEModuleContents (L _ mod_name), _)@@ -962,6 +975,7 @@ fullModuleContents :: Bool -- is it a signature -> IfaceMap+ -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap@@ -975,7 +989,7 @@ -> DynFlags -> Avails -> ErrMsgGhc [ExportItem GhcRn]-fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames+fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do@@ -984,7 +998,7 @@ doc <- liftErrMsg (processDocString dflags gre docStr) return [[ExportGroup lev "" doc]] (L _ (DocD (DocCommentNamed _ docStr))) -> do- doc <- liftErrMsg (processDocStringParas dflags gre docStr)+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD valDecl)) | name:_ <- collectHsBindBinders valDecl@@ -1054,19 +1068,32 @@ FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) ->- SigD <$> extractRecSel name n tys (dd_cons defn)- InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))- <- insts- -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)- , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))- , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)- , L _ n <- ns- , selectorFieldOcc n == name- ]- in case matches of- [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)- _ -> error "internal: extractDecl (ClsInstD)"+ if isDataConName name+ then SigD <$> extractPatternSyn name n tys (dd_cons defn)+ else SigD <$> extractRecSel name n tys (dd_cons defn)+ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts })+ | isDataConName name ->+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =+ FamEqn { feqn_rhs = dd+ }+ })) <- insts+ , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))+ ]+ in case matches of+ [d0] -> extractDecl declMap name (noLoc (InstD (DataFamInstD d0)))+ _ -> error "internal: extractDecl (ClsInstD)"+ | otherwise ->+ let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))+ <- insts+ -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)+ , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)+ , L _ n <- ns+ , selectorFieldOcc n == name+ ]+ in case matches of+ [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)+ _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl"
src/Haddock/Interface/LexParseRn.hs view
@@ -33,34 +33,35 @@ import EnumSet import RnEnv (dataTcOccs) -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]+processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name))-processDocStrings dflags gre strs = do- mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs+processDocStrings dflags pkg gre strs = do+ mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data.- MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing+ MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)-processDocStringParas dflags gre (HsDocString fs) =- overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString+ -> ErrMsgM (MDoc Name)+processDocStringParas dflags pkg gre (HsDocString fs) =+ overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString+processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))-processModuleHeader dflags gre safety mayStr = do+processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs- (hmi, doc) = parseModuleHeader dflags str+ (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr Nothing -> pure Nothing
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -24,8 +24,8 @@ -- 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 -> String -> (HaddockModInfo RdrName, MDoc RdrName)-parseModuleHeader dflags str0 =+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)+parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) getKey key str = case parseKey key str of@@ -52,7 +52,7 @@ hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn- }, parseParas dflags str9)+ }, parseParas dflags pkgName str9) -- | This function is how we read keys. --
src/Haddock/Interface/Rename.hs view
@@ -627,11 +627,11 @@ , hswc_wcs = PlaceHolder }) } renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)-renameDocInstance (inst, idoc, L l n) = do+renameDocInstance (inst, idoc, L l n, m) = do inst' <- renameInstHead inst n' <- rename n idoc' <- mapM renameDoc idoc- return (inst', idoc',L l n')+ return (inst', idoc', L l n', m) renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of
src/Haddock/InterfaceFile.hs view
@@ -83,7 +83,7 @@ -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)-binaryInterfaceVersion = 32+binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -486,8 +486,13 @@ return (TableCell i j c) instance Binary Meta where- put_ bh Meta { _version = v } = put_ bh v- get bh = (\v -> Meta { _version = v }) <$> get bh+ put_ bh (Meta v p) = do+ put_ bh v+ put_ bh p+ get bh = do+ v <- get bh+ p <- get bh+ return (Meta v p) instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where put_ bh MetaDoc { _meta = m, _doc = d } = do
src/Haddock/Options.hs view
@@ -29,19 +29,23 @@ optLaTeXStyle, optMathjax, qualification,+ sinceQualification, verbosity, ghcFlags, reexportFlags, readIfaceArgs, optPackageName,- optPackageVersion+ optPackageVersion,+ modulePackageInfo ) where import qualified Data.Char as Char import Data.Version+import Control.Applicative import Distribution.Verbosity import FastString+import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types import Haddock.Utils import Packages@@ -103,6 +107,7 @@ | Flag_PackageName String | Flag_PackageVersion String | Flag_Reexport String+ | Flag_SinceQualification String deriving (Eq, Show) @@ -210,7 +215,9 @@ Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")- "version of the package being documented in usual x.y.z.w format"+ "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'" ] @@ -310,6 +317,14 @@ [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" +sinceQualification :: [Flag] -> Either String SinceQual+sinceQualification flags =+ case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of+ [] -> Right Always+ ["always"] -> Right Always+ ["external"] -> Right External+ [arg] -> Left $ "unknown since-qualification type " ++ show arg+ _:_ -> Left "since-qualification option given multiple times" verbosity :: [Flag] -> Verbosity verbosity flags =@@ -344,3 +359,23 @@ optLast :: [a] -> Maybe a optLast [] = Nothing optLast xs = Just (last xs)+++-- | This function has a potential to return 'Nothing' because package name and+-- versions can no longer reliably be extracted in all cases: if the package is+-- not installed yet then this info is no longer available.+--+-- The @--package-name@ and @--package-version@ Haddock flags allow the user to+-- specify this information manually and it is returned here if present.+modulePackageInfo :: DynFlags+ -> [Flag] -- ^ Haddock flags are checked as they may contain+ -- the package name or version provided by the user+ -- which we prioritise+ -> Module+ -> (Maybe PackageName, Maybe Data.Version.Version)+modulePackageInfo dflags flags modu =+ ( optPackageName flags <|> fmap packageName pkgDb+ , optPackageVersion flags <|> fmap packageVersion pkgDb+ )+ where+ pkgDb = lookupPackage dflags (moduleUnitId modu)
src/Haddock/Parser.hs view
@@ -28,8 +28,8 @@ import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> MetaDoc mod RdrName-parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName+parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString
src/Haddock/Types.hs view
@@ -388,7 +388,7 @@ -- | An instance head that may have documentation and a source location.-type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))+type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module) -- | The head of an instance. Consists of a class name, a list of type -- parameters (which may be annotated with kinds), and an instance type@@ -577,6 +577,12 @@ data HideEmptyContexts = HideEmptyContexts | ShowEmptyToplevelContexts++-- | When to qualify @since@ annotations with their package+data SinceQual+ = Always+ | External -- ^ only qualify when the thing being annotated is from+ -- an external package ----------------------------------------------------------------------------- -- * Error handling