Commits (114)
......@@ -25,5 +25,7 @@ TAGS
.cabal-sandbox
.ghc.environment.*
cabal.sandbox.config
cabal.project.local
cabal.project.local~
.stack-work/
......@@ -26,9 +26,9 @@ before_cache:
matrix:
include:
- compiler: "ghc-8.2.1"
- compiler: "ghc-8.4.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.2], sources: [hvr-ghc]}}
- compiler: "ghc-head"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}
......@@ -51,8 +51,8 @@ install:
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- rm -fv cabal.project.local
- rm -f cabal.project.freeze
- travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
- travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
- travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all
- travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all
# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
......@@ -69,12 +69,12 @@ script:
- rm -fv cabal.project.local
# this builds all libraries and executables (without tests/benchmarks)
- rm -f cabal.project.freeze
- cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
- cabal new-build -w ${HC} --disable-tests --disable-benchmarks --allow-newer --constraint 'setup.Cabal installed' all
# this builds all libraries and executables (including tests/benchmarks)
# - rm -rf ./dist-newstyle
# build & run tests
- cabal new-build -w ${HC} ${TEST} ${BENCH} all
- if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
- cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer --constraint 'setup.Cabal installed' all
- if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer --constraint 'setup.Cabal installed' all; fi
# EOF
## Changes in version 2.18.2
## TBD / GHC-8.5+
* to be released
* Overhaul handling of data declarations in XHTML and LaTeX. Adds support for
documenting individual arguments of constructors/patterns (#709)
## Changes in version 2.20.0
TODO
## Changes in version 2.19.1
* Show where instances are defined (#748)
* `@since` includes package name (#452, #550, #749)
## Changes in version 2.19.0.1
* Support for linking unicode operators (#458)
* Hyperlinker: Fix file handle leak in (#763)
## Changes in version 2.19.0
* Haddock now supports tables in documentation inspired by reSTs grid tables
* `--quickjump` allows for quick navigation in documentation on hackage and
other documentation hosting sites.
* A --reexport flag, which can be used to add extra modules to the
top-level module tree
......@@ -19,11 +43,17 @@
* Fix: Generate constraint signatures for constructors exported as pattern
synonyms (#663)
* The hyperlinker backend now uses the GHC lexer instead of a custom one.
This notably fixes rendering of quasiquotes.
* Overhaul Haddock's rendering of kind signatures so that invisible kind
parameters are not printed (#681) (Fixes #544)
* Overhaul handling of data declarations in XHTML and LaTeX. Adds support for
documenting individual arguments of constructors/patterns (#709)
* Recognise `SPDX-License-Identifier` as alias for `License` in module header
parser (#743)
* Remove the response file related utilities, and use the ones that
come with `base` (Trac #13896)
* Remove the response file related utilities, and use the ones that
come with `base` (Trac #13896)
......
......@@ -31,9 +31,9 @@ and then proceed using your favourite build tool.
#### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html)
```bash
cabal new-build -w ghc-8.2.1
cabal new-build -w ghc-8.4.1
# build & run the test suite
cabal new-test -w ghc-8.2.1
cabal new-test -w ghc-8.4.1
```
#### Using Cabal sandboxes
......
......@@ -118,3 +118,20 @@ definitions with "[thing]"
{-# OPTIONS_HADDOCK show-extensions #-}
Show all enabled LANGUAGE extensions
```
# Grid tables
```
+------------------------+------------+----------+----------+
| Header row, column 1 | Header 2 | Header 3 | Header 4 |
| (header rows optional) | | | |
+========================+============+==========+==========+
| body row 1, column 1 | column 2 | column 3 | column 4 |
+------------------------+------------+----------+----------+
| body row 2 | Cells may span columns. |
+------------------------+------------+---------------------+
| body row 3 | Cells may | \[ |
+------------------------+ span rows. | f(n) = \sum_{i=1} |
| body row 4 | | \] |
+------------------------+------------+---------------------+
```
......@@ -1092,6 +1092,26 @@ If the output format supports it, the mathematics will be rendered
inside the documentation. For example, the HTML backend will display
the mathematics via `MathJax <https://www.mathjax.org>`__.
Grid Tables
~~~~~~~~~~~
Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. ::
-- | This is a grid table:
--
-- +------------------------+------------+----------+----------+
-- | Header row, column 1 | Header 2 | Header 3 | Header 4 |
-- | (header rows optional) | | | |
-- +========================+============+==========+==========+
-- | body row 1, column 1 | column 2 | column 3 | column 4 |
-- +------------------------+------------+----------+----------+
-- | body row 2 | Cells may span columns. |
-- +------------------------+------------+---------------------+
-- | body row 3 | Cells may | \[ |
-- +------------------------+ span rows. | f(n) = \sum_{i=1} |
-- | body row 4 | | \] |
-- +------------------------+------------+---------------------+
Anchors
~~~~~~~
......
cabal-version: 2.0
name: haddock-api
version: 2.18.2
version: 2.20.0
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
......@@ -12,7 +13,6 @@ bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
cabal-version: >= 2.0
extra-source-files:
CHANGES.md
......@@ -41,10 +41,10 @@ library
-- this package typically supports only single major versions
build-depends: base ^>= 4.12.0
, Cabal ^>= 2.0.0
, ghc ^>= 8.3
, Cabal ^>= 2.3.0
, ghc ^>= 8.5
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.4.6
, haddock-library ^>= 1.6.0
, xhtml ^>= 3000.2.2
-- Versions for the dependencies below are transitively pinned by
......@@ -124,27 +124,71 @@ test-suite spec
test
, src
-- NB: We only use a small subset of lib:haddock-api here, which
-- explains why this component has a smaller build-depends set
other-modules:
Haddock
Haddock.Backends.Hoogle
Haddock.Backends.Hyperlinker
Haddock.Backends.Hyperlinker.Ast
Haddock.Backends.Hyperlinker.Renderer
Haddock.Backends.Hyperlinker.Utils
Haddock.Backends.LaTeX
Haddock.Backends.Xhtml
Haddock.Backends.Xhtml.Decl
Haddock.Backends.Xhtml.DocMarkup
Haddock.Backends.Xhtml.Layout
Haddock.Backends.Xhtml.Meta
Haddock.Backends.Xhtml.Names
Haddock.Backends.Xhtml.Themes
Haddock.Backends.Xhtml.Types
Haddock.Backends.Xhtml.Utils
Haddock.Convert
Haddock.Doc
Haddock.GhcUtils
Haddock.Interface
Haddock.Interface.AttachInstances
Haddock.Interface.Create
Haddock.Interface.Json
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
Haddock.Interface.Rename
Haddock.Interface.Specialize
Haddock.InterfaceFile
Haddock.ModuleTree
Haddock.Options
Haddock.Parser
Haddock.Syb
Haddock.Types
Haddock.Utils
Haddock.Utils.Json
Haddock.Version
Paths_haddock_api
Haddock.Backends.Hyperlinker.ParserSpec
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Types
build-depends:
ghc ^>= 8.3
, hspec ^>= 2.4.4
, QuickCheck ^>= 2.10
build-depends: Cabal ^>= 2.3
, ghc ^>= 8.5
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.6.0
, xhtml ^>= 3000.2.2
, hspec >= 2.4.4 && < 2.6
, QuickCheck ^>= 2.11
-- Versions for the dependencies below are transitively pinned by
-- the non-reinstallable `ghc` package and hence need no version
-- bounds
build-depends:
base
, containers
build-depends: base
, array
, bytestring
, containers
, deepseq
, directory
, filepath
, ghc-boot
, transformers
build-tool-depends:
hspec-discover:hspec-discover ^>= 2.4.4
hspec-discover:hspec-discover >= 2.4.4 && < 2.6
source-repository head
type: git
......
......@@ -392,6 +392,20 @@ td.rdoc p {
}
.doc table {
border-collapse: collapse;
border-spacing: 0px;
}
.doc th,
.doc td {
padding: 5px;
border: 1px solid #ddd;
}
.doc th {
background-color: #f0f0f0;
}
#footer {
background-color: #000099;
......
......@@ -443,6 +443,21 @@ div#style-menu-holder {
margin-top: 0.8em;
}
.doc table {
border-collapse: collapse;
border-spacing: 0px;
}
.doc th,
.doc td {
padding: 5px;
border: 1px solid #ddd;
}
.doc th {
background-color: #f0f0f0;
}
.clearfix:after {
clear: both;
content: " ";
......
......@@ -107,7 +107,15 @@ class QuickJump extends Component<QuickJumpProps, QuickJumpState> {
caseSensitive: true,
includeScore: true,
tokenize: true,
keys: ["name", "module"]
keys: [ {
name: "name",
weight: 0.7
},
{
name: "module",
weight: 0.3
}
]
}),
moduleResults: []
});
......@@ -143,7 +151,7 @@ class QuickJump extends Component<QuickJumpProps, QuickJumpState> {
}
hide() {
this.setState({ isVisible: false });
this.setState({ isVisible: false, searchString: '' });
}
show() {
......@@ -409,4 +417,4 @@ export function init(docBaseUrl?: string, showHide?: (action: () => void) => voi
}
// export to global object
(window as any).quickNav = { init: init };
\ No newline at end of file
(window as any).quickNav = { init: init };
......@@ -8,6 +8,7 @@
width: 44em;
z-index: 1000;
pointer-events: none;
overflow-y: auto;
}
#search.hidden {
......@@ -42,7 +43,6 @@
box-sizing: border-box;
border: 0.05em solid #b2d5fb;
background: #e8f3ff;
overflow-y: auto;
}
#search-form input + #search-results {
......@@ -161,4 +161,4 @@
margin: 0 0.1em;
}
/* @end */
\ No newline at end of file
/* @end */
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
......@@ -25,7 +25,6 @@ module Haddock (
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.Options
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 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- 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 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- 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 @@ haddockWithGhc ghc args = handleTopExceptions $ do
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 @@ readPackagesAndProcessModules flags files = do
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 @@ renderStep dflags flags qual pkgs interfaces = do
((_, 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 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
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
......@@ -277,7 +281,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
| Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
| otherwise = srcModule
srcMap = mkSrcMap $ Map.union
srcMap = Map.union
(Map.map SrcExternal extSrcMap)
(Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
......@@ -323,24 +327,34 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
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 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
-- 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 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
++ " 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 @@ readInterfaceFiles :: MonadIO m
-> [(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) =
......@@ -439,13 +439,26 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
_ <- setSessionDynFlags dynflags''
ghcActs dynflags''
where
-- ignore sublists of flags that start with "+RTS" and end in "-RTS"
--
-- See https://github.com/haskell/haddock/issues/666
filterRtsFlags :: [String] -> [String]
filterRtsFlags flgs = foldr go (const []) flgs True
where go "-RTS" func _ = func True
go "+RTS" func _ = func False
go _ func False = func False
go arg func True = arg : func True
parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
parseGhcFlags dynflags = do
-- TODO: handle warnings?
(dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags)
let flags' = filterRtsFlags flags
(dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
if not (null rest)
then throwE ("Couldn't parse GHC options: " ++ unwords flags)
then throwE ("Couldn't parse GHC options: " ++ unwords flags')
else return dynflags'
unsetPatternMatchWarnings :: DynFlags -> DynFlags
......@@ -596,10 +609,15 @@ getPrologue dflags flags =
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
getInTreeDir :: IO String
......
......@@ -128,6 +128,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
f (TyClD _ (FamDecl _ d)) = ppFam dflags d
f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
f (SigD _ sig) = ppSig dflags sig ++ ppFixities
......@@ -140,11 +141,7 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags (TypeSig _ names sig) subdocs
= concatMap mkDocSig names
where
mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
++ [pp_sig dflags names (hsSigWcType sig)]
getDoc :: Located Name -> [Documentation Name]
getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
ppSigWithDoc _ _ _ = []
......@@ -172,10 +169,14 @@ ppClass dflags decl subdocs =
ppTyFams
| null $ tcdATs decl = ""
| otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
[ map ppr (tcdATs decl)
[ map pprTyFam (tcdATs decl)
, map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
]
pprTyFam :: LFamilyDecl GhcRn -> SDoc
pprTyFam (L _ at) = vcat' $ map text $
mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)
whereWrapper elems = vcat'
[ text "where" <+> lbrace
, nest 4 . vcat . map (Outputable.<> semi) $ elems
......@@ -191,6 +192,16 @@ ppClass dflags decl subdocs =
, tcdSExt = emptyNameSet
}
ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
ppFam dflags decl@(FamilyDecl { fdInfo = info })
= [out dflags decl']
where
decl' = case info of
-- We don't need to print out a closed type family's equations
-- for Hoogle, so pretend it doesn't have any.
ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
_ -> decl
ppFam _ XFamilyDecl {} = panic "ppFam"
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x =
......@@ -213,13 +224,12 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
-- GHC gives out "data Bar =", we want to delete the equals.
-- There's no need to worry about parenthesizing infix data type names,
-- since this Outputable instance for TyClDecl gets this right already.
showData d = unwords $ if last xs == "=" then init xs else xs
where
xs = words $ out dflags d
nam = out dflags $ tyClDeclLName d
f w = if w == nam then operator nam else w
ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
......@@ -285,6 +295,10 @@ docWith dflags header d
lines header ++ ["" | header /= "" && isJust d] ++
maybe [] (showTags . markup (markupTag dflags)) d
mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
where
getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
deriving Show
......@@ -328,7 +342,8 @@ markupTag dflags = Markup {
markupAName = const $ str "",
markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString,
markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h
markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h,
markupTable = \(Table _ _) -> str "TODO: table"
}
......
......@@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
import qualified SrcLoc
import qualified Outputable as GHC
import Control.Applicative
......@@ -52,10 +53,10 @@ type DetailsMap = Map.Map Position (Span, TokenDetails)
mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
mkDetailsMap xs =
Map.fromListWith select_details [ (start, (token_span, token_details))
Map.fromListWith select_details [ (start, (span, token_details))
| (ghc_span, token_details) <- xs
, Just !token_span <- [ghcSrcSpanToSpan ghc_span]
, let start = spStart token_span
, GHC.RealSrcSpan span <- [ghc_span]
, let start = SrcLoc.realSrcSpanStart span
]
where
-- favour token details which appear earlier in the list
......@@ -63,17 +64,11 @@ mkDetailsMap xs =
lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
lookupBySpan span details = do
(_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
guard (tok_span `containsSpan` span )
let pos = SrcLoc.realSrcSpanStart span
(_, (tok_span, tok_details)) <- Map.lookupLE pos details
guard (tok_span `SrcLoc.containsSpan` span)
return tok_details
ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
, spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
})
ghcSrcSpanToSpan _ = Nothing
enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
enrichToken (Token typ _ spn) dm
| typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
......@@ -99,9 +94,12 @@ variables =
types :: GHC.RenamedSource -> LTokenDetails
types = everythingInRenamedSource ty
where
ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
ty term = case cast term of
(Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
(Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
(sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
_ -> empty
-- | Obtain details map for identifier bindings.
......@@ -117,6 +115,11 @@ binds = everythingInRenamedSource
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
(Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
_ -> empty
patsyn_binds term = case cast term of
(Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
_ -> empty
pat term = case cast term of
(Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
......@@ -142,6 +145,7 @@ decls :: GHC.RenamedSource -> LTokenDetails
decls (group, _, _, _) = concatMap ($ group)
[ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
, everythingInRenamedSource fun . GHC.hs_valds
, everythingInRenamedSource fix . GHC.hs_fixds
, everythingInRenamedSource (con `Syb.combine` ins)
]
where
......@@ -149,11 +153,16 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
GHC.SynDecl _ name _ _ _ -> pure . decl $ name
GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
GHC.ClassDecl{..} ->
[decl tcdLName]
++ concatMap sig tcdSigs
++ concatMap tyfam tcdATs
GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
(Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
(Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
......@@ -171,7 +180,17 @@ decls (group, _, _, _) = concatMap ($ group)
Just (field :: GHC.ConDeclField GHC.GhcRn)
-> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
fix term = case cast term of
Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
-> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn)
-> GHC.panic "haddock:decls"
Nothing -> empty
tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
......@@ -190,10 +209,11 @@ imports src@(_, imps, _, _) =
(Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
(Just (GHC.IEModuleContents _ m)) -> pure $ modu m
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
imp idecl | not . GHC.ideclImplicit $ idecl =
let (GHC.L sspan name) = GHC.ideclName idecl
in Just (sspan, RtkModule name)
imp _ = Nothing
modu (GHC.L sspan name) = (sspan, RtkModule name)
imp idecl
| not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
| otherwise = Nothing
{-# LANGUAGE RecordWildCards #-}
module Haddock.Backends.Hyperlinker.Renderer (render) where
......@@ -15,7 +14,6 @@ import System.FilePath.Posix ((</>))
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as Map
import Text.XHtml (Html, HtmlAttr, (!))
......@@ -29,36 +27,10 @@ render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
-> Html
render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
data TokenGroup
= GrpNormal Token
| GrpRich TokenDetails [Token]
-- | Group consecutive tokens pointing to the same element.
--
-- We want to render qualified identifiers as one entity. For example,
-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for
-- better user experience when highlighting and clicking links, these tokens
-- should be regarded as one identifier. Therefore, before rendering we must
-- group consecutive elements pointing to the same 'GHC.Name' (note that even
-- dot token has it if it is part of qualified name).
groupTokens :: [RichToken] -> [TokenGroup]
groupTokens [] = []
groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)
groupTokens ((RichToken tok (Just det)):rest) =
let (grp, rest') = span same rest
in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')
where
same (RichToken _ (Just det')) = det == det'
same _ = False
body :: SrcMap -> [RichToken] -> Html
body srcs tokens =
Html.body . Html.pre $ hypsrc
body srcs tokens = Html.body . Html.pre $ hypsrc
where
hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
hypsrc = mconcat . map (richToken srcs) $ tokens
header :: Maybe FilePath -> Maybe FilePath -> Html
......@@ -79,29 +51,20 @@ header mcss mjs =
, Html.src scriptFile
]
tokenGroup :: SrcMap -> TokenGroup -> Html
tokenGroup _ (GrpNormal tok@(Token { .. }))
| tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
| otherwise = tokenSpan tok ! attrs
-- | Given information about the source position of definitions, render a token
richToken :: SrcMap -> RichToken -> Html
richToken srcs (RichToken Token{..} details)
| tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue
| otherwise = linked content
where
attrs = [ multiclass . tokenStyle $ tkType ]
tokenGroup srcs (GrpRich det tokens) =
externalAnchor det . internalAnchor det . hyperlink srcs det $ content
where
content = mconcat . map (richToken det) $ tokens
richToken :: TokenDetails -> Token -> Html
richToken det tok =
tokenSpan tok ! [ multiclass style ]
where
style = (tokenStyle . tkType) tok ++ richTokenStyle det
tokenSpan :: Token -> Html
tokenSpan = Html.thespan . Html.toHtml . tkValue
content = tokenSpan ! [ multiclass style ]
tokenSpan = Html.thespan (Html.toHtml tkValue)
style = tokenStyle tkType ++ maybe [] richTokenStyle details
-- If we have name information, we can make links
linked = case details of
Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d
Nothing -> id
richTokenStyle :: TokenDetails -> [StyleClass]
richTokenStyle (RtkVar _) = ["hs-var"]
......@@ -155,7 +118,7 @@ internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
Just (SrcExternal path) -> Html.anchor content !
......@@ -165,12 +128,14 @@ externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
mdl = GHC.nameModule name
externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
Just SrcLocal -> Html.anchor content !
externalModHyperlink srcs name content =
let srcs' = Map.mapKeys GHC.moduleName srcs in
case Map.lookup name srcs' of
Just SrcLocal -> Html.anchor content !
[ Html.href $ hypSrcModuleUrl' name ]
Just (SrcExternal path) -> Html.anchor content !
Just (SrcExternal path) -> Html.anchor content !
[ Html.href $ path </> hypSrcModuleUrl' name ]
Nothing -> content
Nothing -> content
renderSpace :: Int -> String -> Html
......
......@@ -4,8 +4,6 @@ module Haddock.Backends.Hyperlinker.Types where
import qualified GHC
import Data.Map (Map)
import qualified Data.Map as Map
data Token = Token
{ tkType :: TokenType
......@@ -14,23 +12,8 @@ data Token = Token
}
deriving (Show)
data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
deriving (Eq, Ord, Show)
data Span = Span
{ spStart :: !Position
, spEnd :: !Position
}
deriving (Show)
-- | Tests whether the first span "contains" the other span, meaning
-- that it covers at least as much source code. True where spans are equal.
containsSpan :: Span -> Span -> Bool
containsSpan s1 s2 =
spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2
type Position = GHC.RealSrcLoc
type Span = GHC.RealSrcSpan
data TokenType
= TkIdentifier
......@@ -80,15 +63,5 @@ data SrcPath
| SrcLocal
-- | Mapping from modules to cross-package source paths.
--
-- This mapping is actually a pair of maps instead of just one map. The reason
-- for this is because when hyperlinking modules in import lists we have no
-- 'GHC.Module' available. On the other hand, we can't just use map with
-- 'GHC.ModuleName' as indices because certain modules may have common name
-- but originate in different packages. Hence, we use both /rich/ and /poor/
-- versions, where the /poor/ is just projection of /rich/ one cached in pair
-- for better performance.
type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
type SrcMap = Map GHC.Module SrcPath
mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
......@@ -27,7 +27,7 @@ import GHC
import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
import FastString ( unpackFS, unpackLitString, zString )
import FastString ( unpackFS )
import Outputable ( panic)
import qualified Data.Map as Map
......@@ -539,13 +539,11 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
vcat [ ppFunSig doc names (hsSigWcType typ) unicode
vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
-- there are different subdocs for different names in a single
-- type signature?
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
]
instancesBit = ppDocInstances unicode instances
......@@ -563,14 +561,14 @@ ppDocInstances unicode (i : rest)
(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)
......@@ -1002,8 +1000,7 @@ ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
ppr_mono_ty _ (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
ppr_tylit :: HsTyLit -> Bool -> LaTeX
......@@ -1139,7 +1136,8 @@ parLatexMarkup ppId = Markup {
markupAName = \_ _ -> empty,
markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
markupHeader = \(Header l h) p -> header l (h p)
markupHeader = \(Header l h) p -> header l (h p),
markupTable = \(Table h b) p -> table h b p
}
where
header 1 d = text "\\section*" <> braces d
......@@ -1148,6 +1146,8 @@ parLatexMarkup ppId = Markup {
| l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
table _ _ _ = text "{TODO: Table}"
fixString Plain s = latexFilter s
fixString Verb s = s
fixString Mono s = latexMonoFilter s
......@@ -1265,12 +1265,12 @@ quote :: LaTeX -> LaTeX
quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX
dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX
dcolon unicode = text (if unicode then "∷" else "::")
arrow unicode = text (if unicode then "→" else "->")
darrow unicode = text (if unicode then "⇒" else "=>")
forallSymbol unicode = text (if unicode then "∀" else "forall")
starSymbol unicode = text (if unicode then "★" else "*")
dot :: LaTeX
dot = char '.'
......