aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs5
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs152
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Meta.hs2
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs8
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs7
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs8
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs84
-rw-r--r--haddock-api/src/Haddock/Options.hs24
-rw-r--r--haddock-api/src/Haddock/Parser.hs1
-rw-r--r--haddock-api/src/Haddock/Types.hs4
-rw-r--r--haddock-api/src/Haddock/Utils/Json.hs3
18 files changed, 245 insertions, 88 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 221580cc..582c535d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -353,7 +353,7 @@ markupTag dflags = Markup {
markupMathInline = const $ str "<math>",
markupMathDisplay = const $ str "<math>",
markupUnorderedList = box (TagL 'u'),
- markupOrderedList = box (TagL 'o'),
+ markupOrderedList = box (TagL 'o') . map snd,
markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
markupCodeBlock = box TagPre,
markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index d77990d1..7fa5a443 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
@@ -142,8 +141,8 @@ richToken srcs details Token{..}
contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details
- -- pick an arbitary non-evidence identifier to hyperlink with
- identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details
+ -- pick an arbitrary non-evidence identifier to hyperlink with
+ identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details
notEvidence = not . any isEvidenceContext . identInfo
-- If we have name information, we can make links
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 349c6e8e..faa23d6a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1265,7 +1265,7 @@ latexMarkup = Markup
, markupPic = \p _ -> inlineElem (markupPic p)
, markupMathInline = \p _ -> inlineElem (markupMathInline p)
, markupMathDisplay = \p _ -> blockElem (markupMathDisplay p)
- , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p))
+ , markupOrderedList = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p))
, markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))
, markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty)))
, markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))
@@ -1301,7 +1301,7 @@ latexMarkup = Markup
Just label -> text "\\href" <> braces (text url) <> braces label
Nothing -> text "\\url" <> braces (text url)
- -- Is there a better way of doing this? Just a space is an aribtrary choice.
+ -- Is there a better way of doing this? Just a space is an arbitrary choice.
markupPic (Picture uri title) = parens (imageText title)
where
imageText Nothing = beg
@@ -1333,7 +1333,7 @@ rdrDocToLaTeX doc = markup latexMarkup doc Plain empty
data StringContext
= Plain -- ^ all special characters have to be escape
- | Mono -- ^ on top of special characters, escape space chraacters
+ | Mono -- ^ on top of special characters, escape space characters
| Verb -- ^ don't escape anything
@@ -1394,7 +1394,7 @@ bold ltx = text "\\textbf" <> braces ltx
-- TODO: @verbatim@ is too much since
--
--- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX
+-- * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX
-- representing that markup gets printed verbatim
-- * Verbatim environments are not supported everywhere (example: not nested
-- inside a @tabulary@ environment)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index b7674b24..4cc6aa77 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -28,7 +28,9 @@ import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
+import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo)
import Haddock.ModuleTree
+import Haddock.Options (Visibility (..))
import Haddock.Types
import Haddock.Version
import Haddock.Utils
@@ -78,6 +80,7 @@ ppHtml :: UnitState
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
-> Maybe String -- ^ Package name
+ -> PackageInfo -- ^ Package info
-> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> Bool -- ^ Also write Quickjump index
@@ -86,7 +89,7 @@ ppHtml :: UnitState
ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_base_url maybe_contents_url maybe_index_url unicode
- pkg qual debug withQuickjump = do
+ pkg packageInfo qual debug withQuickjump = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -94,13 +97,20 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
when (isNothing maybe_contents_url) $
ppHtmlContents state odir doctitle maybe_package
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
- (map toInstalledIface visible_ifaces ++ reexported_ifaces)
+ withQuickjump
+ [PackageInterfaces
+ { piPackageInfo = packageInfo
+ , piVisibility = Visible
+ , piInstalledInterfaces = map toInstalledIface visible_ifaces
+ ++ reexported_ifaces
+ }]
False -- we don't want to display the packages in a single-package contents
prologue debug pkg (makeContentsQual qual)
when (isNothing maybe_index_url) $ do
ppHtmlIndex odir doctitle maybe_package
themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
+ withQuickjump
(map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
when withQuickjump $
@@ -109,7 +119,8 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
mapM_ (ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
- maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
+ maybe_contents_url maybe_index_url withQuickjump
+ unicode pkg qual debug) visible_ifaces
copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
@@ -155,6 +166,15 @@ headHtml docTitle themes mathjax_url base_url =
, "}"
, "});" ]
+quickJumpButtonLi :: Bool -- ^ With Quick Jump?
+ -> Maybe Html
+-- The TypeScript should replace this <li> element, given its id. However, in
+-- case it does not, the element is given content here too.
+quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"]
+ << anchor ! [href "#"] << "Quick Jump"
+
+quickJumpButtonLi False = Nothing
+
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _, _) Nothing =
Just (anchor ! [href src_base_url] << "Source")
@@ -193,20 +213,18 @@ indexButton maybe_index_url
bodyHtml :: String -> Maybe Interface
-> SourceURLs -> WikiURLs
-> Maybe String -> Maybe String
+ -> Bool -- ^ With Quick Jump?
-> Html -> Html
bodyHtml doctitle iface
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url
+ withQuickjump
pageContent =
body << [
divPackageHeader << [
nonEmptySectionName << doctitle,
- unordList (catMaybes [
- srcButton maybe_source_url iface,
- wikiButton maybe_wiki_url (ifaceMod <$> iface),
- contentsButton maybe_contents_url,
- indexButton maybe_index_url])
- ! [theclass "links", identifier "page-menu"]
+ ulist ! [theclass "links", identifier "page-menu"]
+ << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis)
],
divContent << pageContent,
divFooter << paragraph << (
@@ -215,6 +233,13 @@ bodyHtml doctitle iface
(" version " ++ projectVersion)
)
]
+ where
+ otherButtonLis = (fmap . fmap) (li <<)
+ [ srcButton maybe_source_url iface
+ , wikiButton maybe_wiki_url (ifaceMod <$> iface)
+ , contentsButton maybe_contents_url
+ , indexButton maybe_index_url
+ ]
moduleInfo :: Interface -> Html
moduleInfo iface =
@@ -277,30 +302,44 @@ ppHtmlContents
-> Maybe String
-> SourceURLs
-> WikiURLs
- -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
+ -> Bool -- ^ With Quick Jump?
+ -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName)
-> Bool
-> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents state odir doctitle _maybe_package
themes mathjax_url maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
- let tree = mkModuleTree state showPkgs
- [(instMod iface, toInstalledDescription iface)
- | iface <- ifaces
- , not (instIsSig iface)]
- sig_tree = mkModuleTree state showPkgs
- [(instMod iface, toInstalledDescription iface)
- | iface <- ifaces
- , instIsSig iface]
+ maybe_source_url maybe_wiki_url withQuickjump
+ packages showPkgs prologue debug pkg qual = do
+ let trees =
+ [ ( piPackageInfo pinfo
+ , mkModuleTree state showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- piInstalledInterfaces pinfo
+ , not (instIsSig iface)
+ ]
+ )
+ | pinfo <- packages
+ ]
+ sig_trees =
+ [ ( piPackageInfo pinfo
+ , mkModuleTree state showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- piInstalledInterfaces pinfo
+ , instIsSig iface
+ ]
+ )
+ | pinfo <- packages
+ ]
html =
headHtml doctitle themes mathjax_url Nothing +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
- Nothing maybe_index_url << [
+ Nothing maybe_index_url withQuickjump << [
ppPrologue pkg qual doctitle prologue,
- ppSignatureTree pkg qual sig_tree,
- ppModuleTree pkg qual tree
+ ppSignatureTrees pkg qual sig_trees,
+ ppModuleTrees pkg qual trees
]
createDirectoryIfMissing True odir
writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
@@ -315,17 +354,37 @@ ppPrologue _ _ _ Nothing = noHtml
ppPrologue pkg qual title (Just doc) =
divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))
-
-ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
-ppSignatureTree _ _ [] = mempty
-ppSignatureTree pkg qual ts =
- divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
-
-
-ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
-ppModuleTree _ _ [] = mempty
-ppModuleTree pkg qual ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)
+ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
+ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
+ppSignatureTrees pkg qual [(info, ts)] =
+ divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
+ppSignatureTrees pkg qual tss =
+ divModuleList <<
+ (sectionName << "Signatures"
+ +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts
+ | (i, (info, ts)) <- zip [(1::Int)..] tss
+ ])
+
+ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
+ppSignatureTree _ _ _ _ [] = mempty
+ppSignatureTree pkg qual p info ts =
+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)
+
+ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
+ppModuleTrees _ _ tss | all (null . snd) tss = mempty
+ppModuleTrees pkg qual [(info, ts)] =
+ divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)
+ppModuleTrees pkg qual tss =
+ divPackageList <<
+ (sectionName << "Packages"
+ +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts
+ | (i, (info, ts)) <- zip [(1::Int)..] tss
+ ])
+
+ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
+ppModuleTree _ _ _ _ [] = mempty
+ppModuleTree pkg qual p info ts =
+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)
mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
@@ -418,11 +477,16 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
(errors, installedIndexes) <-
partitionEithers
<$> traverse
- (\ifaceFile ->
+ (\ifaceFile -> do
let indexFile = takeDirectory ifaceFile
- FilePath.</> "doc-index.json" in
- bimap (indexFile,) (map (fixLink ifaceFile))
- <$> eitherDecodeFile @[JsonIndexEntry] indexFile)
+ FilePath.</> "doc-index.json"
+ a <- doesFileExist indexFile
+ if a then
+ bimap (indexFile,) (map (fixLink ifaceFile))
+ <$> eitherDecodeFile @[JsonIndexEntry] indexFile
+ else
+ return (Right [])
+ )
installedIfacesPaths
traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)
errors
@@ -486,11 +550,12 @@ ppHtmlIndex :: FilePath
-> Maybe String
-> SourceURLs
-> WikiURLs
+ -> Bool -- ^ With Quick Jump?
-> [InstalledInterface]
-> Bool
-> IO ()
ppHtmlIndex odir doctitle _maybe_package themes
- maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
+ maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do
let html = indexPage split_indices Nothing
(if split_indices then [] else index)
@@ -509,7 +574,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
- maybe_contents_url Nothing << [
+ maybe_contents_url Nothing withQuickjump << [
if showLetters then indexInitialLetterLinks else noHtml,
if null items then noHtml else
divIndex << [sectionName << indexName ch, buildIndex items]
@@ -607,11 +672,14 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> Maybe String -> SourceURLs -> WikiURLs -> BaseURL
- -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
+ -> Maybe String -> Maybe String
+ -> Bool -- ^ With Quick Jump?
+ -> Bool -> Maybe Package -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
- maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
+ maybe_contents_url maybe_index_url withQuickjump
+ unicode pkg qual debug iface = do
let
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
@@ -631,7 +699,7 @@ ppHtmlModule odir doctitle themes
headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url << [
+ maybe_contents_url maybe_index_url withQuickjump << [
divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a54bb0aa..3dea1012 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -727,7 +727,7 @@ ppInstanceSigs links splice unicode qual sigs = do
L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index b8f5ac0f..91a5b120 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -46,7 +46,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
markupModule = \(ModLink m lbl) ->
let (mdl,ref) = break (=='#') m
- -- Accomodate for old style
+ -- Accommodate for old style
-- foo\#bar anchors
mdl' = case reverse mdl of
'\\':_ -> init mdl
@@ -57,7 +57,7 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupBold = strong,
markupMonospaced = thecode,
markupUnorderedList = unordList,
- markupOrderedList = ordList,
+ markupOrderedList = makeOrdList,
markupDefList = defList,
markupCodeBlock = pre,
markupHyperlink = \(Hyperlink url mLabel)
@@ -112,9 +112,12 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+ makeOrdList :: HTML a => [(Int, a)] -> Html
+ makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items
+
-- | We use this intermediate type to transform the input 'Doc' tree
-- in an arbitrary way before rendering, such as grouping some
--- elements. This is effectivelly a hack to prevent the 'Doc' type
+-- elements. This is effectively a hack to prevent the 'Doc' type
-- from changing if it is possible to recover the layout information
-- we won't need after the fact.
data Hack a id =
@@ -277,5 +280,5 @@ cleanup = overDoc (markup fmtUnParagraphLists)
fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
fmtUnParagraphLists = idMarkup {
markupUnorderedList = DocUnorderedList . map unParagraph,
- markupOrderedList = DocOrderedList . map unParagraph
+ markupOrderedList = DocOrderedList . map (\(index, a) -> (index, unParagraph a))
}
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 8f04a21f..575249ad 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.Layout (
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynopsis, divInterface,
- divIndex, divAlphabet, divModuleList, divContentsList,
+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList,
sectionName,
nonEmptySectionName,
@@ -81,7 +81,7 @@ nonEmptySectionName c
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynopsis, divInterface,
- divIndex, divAlphabet, divModuleList, divContentsList
+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList
:: Html -> Html
divPackageHeader = sectionDiv "package-header"
@@ -96,6 +96,7 @@ divInterface = sectionDiv "interface"
divIndex = sectionDiv "index"
divAlphabet = sectionDiv "alphabet"
divModuleList = sectionDiv "module-list"
+divPackageList = sectionDiv "module-list"
--------------------------------------------------------------------------------
@@ -219,7 +220,7 @@ subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
wrap = ((h1 << "Orphan instances") +++)
instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice
- id_ = makeAnchorId $ "orphans"
+ id_ = makeAnchorId "orphans"
subInstHead :: String -- ^ Instance unique id (for anchor generation)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
index 621bdd41..540885ac 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
@@ -14,7 +14,7 @@ quickjumpVersion = 1
-- | Writes a json encoded file containing additional
-- information about the generated documentation. This
--- is useful for external tools (e.g. hackage).
+-- is useful for external tools (e.g., Hackage).
writeHaddockMeta :: FilePath -> Bool -> IO ()
writeHaddockMeta odir withQuickjump = do
let
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 7c1dc73b..6c1719dc 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
@@ -136,7 +136,7 @@ hsSigTypeI = sig_body . unLoc
mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
-- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
+-- though the type might have free variables
mkEmptySigType lty@(L loc ty) = L loc $ case ty of
HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
, hst_body = body }
@@ -472,7 +472,7 @@ instance Parent (ConDecl GhcRn) where
instance Parent (TyClDecl GhcRn) where
children d
| isDataDecl d = map unLoc $ concatMap (getConNames . unLoc)
- $ (dd_cons . tcdDataDefn) $ d
+ $ (dd_cons . tcdDataDefn) d
| isClassDecl d =
map (unLoc . fdLName . unLoc) (tcdATs d) ++
[ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
@@ -554,7 +554,7 @@ stringBufferFromByteString bs =
--
-- /O(1)/
takeStringBuffer :: Int -> StringBuffer -> ByteString
-takeStringBuffer !n !(S.StringBuffer fp _ cur) = BS.PS fp cur n
+takeStringBuffer !n (S.StringBuffer fp _ cur) = BS.PS fp cur n
-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second
-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index dc8afa31..4527360f 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index dbd4a9b2..b832128f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -9,7 +9,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wwarn #-}
@@ -83,7 +82,7 @@ import GHC.Types.Unique.Map
newtype IfEnv m = IfEnv
{
- -- | Lookup names in the enviroment.
+ -- | Lookup names in the environment.
ife_lookup_name :: Name -> m (Maybe TyThing)
}
@@ -265,7 +264,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)
let
- -- Warnings in this module and transitive warnings from dependend modules
+ -- Warnings in this module and transitive warnings from dependent modules
warnings :: Map Name (Doc Name)
warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))
@@ -334,7 +333,7 @@ mkAliasMap state impDecls =
M.fromList $
mapMaybe (\(SrcLoc.L _ impDecl) -> do
SrcLoc.L _ alias <- ideclAs impDecl
- return $
+ return
(lookupModuleDyn state
-- TODO: This is supremely dodgy, because in general the
-- UnitId isn't going to look anything like the package
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 92fb2e75..8b27a982 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -130,8 +130,10 @@ jsonDoc (DocUnorderedList xs) = jsonObject
jsonDoc (DocOrderedList xs) = jsonObject
[ ("tag", jsonString "DocOrderedList")
- , ("documents", jsonArray (fmap jsonDoc xs))
+ , ("items", jsonArray (fmap jsonItem xs))
]
+ where
+ jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)]
jsonDoc (DocDefList xys) = jsonObject
[ ("tag", jsonString "DocDefList")
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index f3b57792..4e1964af 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -90,6 +90,10 @@ processModuleHeader dflags pkgName gre safety mayStr = do
where
failure = (emptyHaddockModInfo, Nothing)
+traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b))
+traverseSnd f = traverse (\(x, a) ->
+ (\b -> (x, b)) <$> f a)
+
-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the
-- definitions and a parsed comment and we attempt to make sense of
-- where the identifiers in the comment point to. We're in effect
@@ -152,7 +156,7 @@ rename dflags gre = rn
DocBold doc -> DocBold <$> rn doc
DocMonospaced doc -> DocMonospaced <$> rn doc
DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
- DocOrderedList docs -> DocOrderedList <$> traverse rn docs
+ DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs
DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
@@ -173,7 +177,7 @@ rename dflags gre = rn
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
-- we simply monospace the identifier in most cases except when the
-- identifier is qualified: if the identifier is qualified then we can
--- still try to guess and generate anchors accross modules but the
+-- still try to guess and generate anchors across modules but the
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index db5181c6..f9861708 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -15,9 +16,11 @@
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
- InterfaceFile(..), ifUnitId, ifModule,
- readInterfaceFile, freshNameCache,
- writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
+ InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,
+ PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo,
+ readInterfaceFile, writeInterfaceFile,
+ freshNameCache,
+ binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where
@@ -26,9 +29,12 @@ import Haddock.Types
import Data.IORef
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Version
import Data.Word
+import Text.ParserCombinators.ReadP (readP_to_S)
import GHC.Iface.Binary (getWithUserData, putSymbolTable)
+import GHC.Unit.State
import GHC.Utils.Binary
import GHC.Data.FastMutInt
import GHC.Data.FastString
@@ -37,11 +43,43 @@ import GHC.Types.Name.Cache
import GHC.Types.Unique.FM
import GHC.Types.Unique
+import Haddock.Options (Visibility (..))
+
data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv,
+ -- | Package meta data. Currently it only consist of a package name, which
+ -- is not read from the interface file, but inferred from its name.
+ --
+ -- issue #
+ ifPackageInfo :: PackageInfo,
ifInstalledIfaces :: [InstalledInterface]
}
+data PackageInfo = PackageInfo {
+ piPackageName :: PackageName,
+ piPackageVersion :: Data.Version.Version
+}
+
+ppPackageInfo :: PackageInfo -> String
+ppPackageInfo (PackageInfo name version) | version == makeVersion []
+ = unpackFS (unPackageName name)
+ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version
+
+data PackageInterfaces = PackageInterfaces {
+ piPackageInfo :: PackageInfo,
+ piVisibility :: Visibility,
+ piInstalledInterfaces :: [InstalledInterface]
+}
+
+mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces
+mkPackageInterfaces piVisibility
+ InterfaceFile { ifPackageInfo
+ , ifInstalledIfaces
+ } =
+ PackageInterfaces { piPackageInfo = ifPackageInfo
+ , piVisibility
+ , piInstalledInterfaces = ifInstalledIfaces
+ }
ifModule :: InterfaceFile -> Module
ifModule if_ =
@@ -86,7 +124,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)
-binaryInterfaceVersion = 40
+binaryInterfaceVersion = 41
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -129,7 +167,7 @@ writeInterfaceFile filename iface = do
let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
(putName bin_symtab)
(putFastString bin_dict)
- put_ bh iface
+ putInterfaceFile_ bh iface
-- write the symtab pointer at the front of the file
symtab_p <- tellBin bh
@@ -240,16 +278,48 @@ instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
put_ bh m = put_ bh (Map.toList m)
get bh = fmap (Map.fromList) (get bh)
+instance Binary PackageInfo where
+ put_ bh PackageInfo { piPackageName, piPackageVersion } = do
+ put_ bh (unPackageName piPackageName)
+ put_ bh (showVersion piPackageVersion)
+ get bh = do
+ name <- PackageName <$> get bh
+ versionString <- get bh
+ let version = case readP_to_S parseVersion versionString of
+ [] -> makeVersion []
+ vs -> fst (last vs)
+ return $ PackageInfo name version
instance Binary InterfaceFile where
- put_ bh (InterfaceFile env ifaces) = do
+ put_ bh (InterfaceFile env info ifaces) = do
put_ bh env
+ put_ bh info
put_ bh ifaces
get bh = do
env <- get bh
+ info <- get bh
ifaces <- get bh
- return (InterfaceFile env ifaces)
+ return (InterfaceFile env info ifaces)
+
+
+putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO ()
+putInterfaceFile_ bh (InterfaceFile env info ifaces) = do
+ put_ bh env
+ put_ bh info
+ put_ bh ifaces
+
+getInterfaceFile :: BinHandle -> Word16 -> IO InterfaceFile
+getInterfaceFile bh v | v <= 38 = do
+ env <- get bh
+ let info = PackageInfo (PackageName mempty) (makeVersion [])
+ ifaces <- get bh
+ return (InterfaceFile env info ifaces)
+getInterfaceFile bh _ = do
+ env <- get bh
+ info <- get bh
+ ifaces <- get bh
+ return (InterfaceFile env info ifaces)
instance Binary InstalledInterface where
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index aa10b5b3..78bfe1a1 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -15,6 +15,7 @@
module Haddock.Options (
parseHaddockOpts,
Flag(..),
+ Visibility(..),
getUsage,
optTitle,
outputDir,
@@ -361,18 +362,31 @@ ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
reexportFlags :: [Flag] -> [String]
reexportFlags flags = [ option | Flag_Reexport option <- flags ]
+data Visibility = Visible | Hidden
+ deriving (Eq, Show)
-readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
+readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)]
readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
where
- parseIfaceOption :: String -> (DocPaths, FilePath)
+ parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
parseIfaceOption str =
case break (==',') str of
(fpath, ',':rest) ->
case break (==',') rest of
- (src, ',':file) -> ((fpath, Just src), file)
- (file, _) -> ((fpath, Nothing), file)
- (file, _) -> (("", Nothing), file)
+ (src, ',':rest') ->
+ let src' = case src of
+ "" -> Nothing
+ _ -> Just src
+ in
+ case break (==',') rest' of
+ (visibility, ',':file) | visibility == "hidden" ->
+ ((fpath, src'), Hidden, file)
+ | otherwise ->
+ ((fpath, src'), Visible, file)
+ (file, _) ->
+ ((fpath, src'), Visible, file)
+ (file, _) -> ((fpath, Nothing), Visible, file)
+ (file, _) -> (("", Nothing), Visible, file)
-- | Like 'listToMaybe' but returns the last element instead of the first.
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index 53cf98ad..850fdf7f 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Haddock.Parser
-- Copyright : (c) Mateusz Kowalczyk 2013,
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 7d00c5ec..6c98c830 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -151,7 +151,7 @@ data Interface = Interface
-- | Warnings for things defined in this module.
, ifaceWarningMap :: !WarningMap
- -- | Tokenized source code of module (avaliable if Haddock is invoked with
+ -- | Tokenized source code of module (available if Haddock is invoked with
-- source generation flag).
, ifaceHieFile :: !(Maybe FilePath)
, ifaceDynFlags :: !DynFlags
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
index d5d5ae02..0a796b4a 100644
--- a/haddock-api/src/Haddock/Utils/Json.hs
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@@ -401,7 +400,7 @@ parseIntegralFromDouble d =
let r = toRational d
x = truncate r
in if toRational x == r
- then pure $ x
+ then pure x
else fail $ "unexpected floating number " <> show d
parseIntegral :: Integral a => String -> Value -> Parser a