aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal37
-rw-r--r--haddock-api/resources/html/Ocean.std-theme/ocean.css71
-rw-r--r--haddock-api/resources/html/frames.html2
-rw-r--r--haddock-api/resources/html/haddock-util.js24
-rw-r--r--haddock-api/resources/html/highlight.js27
-rw-r--r--haddock-api/resources/html/solarized.css55
-rw-r--r--haddock-api/src/Haddock.hs106
-rw-r--r--haddock-api/src/Haddock/Backends/HaddockDB.hs18
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs109
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs64
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs185
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs204
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs189
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs85
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs68
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs173
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs89
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs31
-rw-r--r--haddock-api/src/Haddock/Convert.hs60
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs28
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs46
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs65
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs43
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs406
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs9
-rw-r--r--haddock-api/src/Haddock/Options.hs9
-rw-r--r--haddock-api/src/Haddock/Syb.hs55
-rw-r--r--haddock-api/src/Haddock/Types.hs116
-rw-r--r--haddock-api/src/Haddock/Version.hs2
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs98
-rw-r--r--haddock-api/test/Spec.hs1
38 files changed, 2275 insertions, 261 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 292965bf..7835ea50 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -1,5 +1,5 @@
name: haddock-api
-version: 2.16.0
+version: 2.16.2
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
@@ -18,8 +18,10 @@ stability: experimental
data-dir:
resources
data-files:
+ html/solarized.css
html/frames.html
html/haddock-util.js
+ html/highlight.js
html/Classic.theme/haskell_icon.gif
html/Classic.theme/minus.gif
html/Classic.theme/plus.gif
@@ -41,15 +43,16 @@ library
, filepath
, directory
, containers
+ , transformers
, deepseq
, array
, xhtml >= 3000.2 && < 3000.3
, Cabal >= 1.10
, ghc-boot
- , ghc == 7.9.*
+ , ghc >= 7.10 && < 7.12
, ghc-paths
- , haddock-library == 1.2.0.*
+ , haddock-library == 1.2.*
hs-source-dirs:
src
@@ -67,6 +70,7 @@ library
Haddock.Interface.AttachInstances
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
+ Haddock.Interface.Specialize
Haddock.Parser
Haddock.Utils
Haddock.Backends.Xhtml
@@ -80,6 +84,12 @@ library
Haddock.Backends.LaTeX
Haddock.Backends.HaddockDB
Haddock.Backends.Hoogle
+ Haddock.Backends.Hyperlinker
+ Haddock.Backends.Hyperlinker.Ast
+ Haddock.Backends.Hyperlinker.Parser
+ Haddock.Backends.Hyperlinker.Renderer
+ Haddock.Backends.Hyperlinker.Types
+ Haddock.Backends.Hyperlinker.Utils
Haddock.ModuleTree
Haddock.Types
Haddock.Doc
@@ -87,9 +97,30 @@ library
Haddock.InterfaceFile
Haddock.Options
Haddock.GhcUtils
+ Haddock.Syb
Haddock.Convert
Paths_haddock_api
+test-suite spec
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ main-is: Spec.hs
+ ghc-options: -Wall
+
+ hs-source-dirs:
+ test
+ , src
+
+ other-modules:
+ Haddock.Backends.Hyperlinker.ParserSpec
+
+ build-depends:
+ base >= 4.3 && < 4.9
+ , containers
+ , ghc >= 7.10 && < 7.12
+ , hspec
+ , QuickCheck == 2.*
+
source-repository head
type: git
location: https://github.com/haskell/haddock.git
diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index de436324..139335ac 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -41,6 +41,9 @@ a[href]:link { color: rgb(196,69,29); }
a[href]:visited { color: rgb(171,105,84); }
a[href]:hover { text-decoration:underline; }
+a[href].def:link, a[href].def:visited { color: black; }
+a[href].def:hover { color: rgb(78, 98, 114); }
+
/* @end */
/* @group Fonts & Sizes */
@@ -143,15 +146,23 @@ ul.links li a {
background-image: url(plus.gif);
background-repeat: no-repeat;
}
-p.caption.collapser,
-p.caption.expander {
- background-position: 0 0.4em;
-}
.collapser, .expander {
padding-left: 14px;
margin-left: -14px;
cursor: pointer;
}
+p.caption.collapser,
+p.caption.expander {
+ background-position: 0 0.4em;
+}
+
+.instance.collapser, .instance.expander {
+ margin-left: 0px;
+ background-position: left center;
+ min-width: 9px;
+ min-height: 9px;
+}
+
pre {
padding: 0.25em;
@@ -318,6 +329,7 @@ div#style-menu-holder {
height: 80%;
top: 10%;
padding: 0;
+ max-width: 75%;
}
#synopsis .caption {
@@ -378,6 +390,15 @@ div#style-menu-holder {
margin: 0 -0.5em 0 0.5em;
}
+#interface td.src .link {
+ float: right;
+ color: #919191;
+ border-left: 1px solid #919191;
+ background: #f0f0f0;
+ padding: 0 0.5em 0.2em;
+ margin: 0 -0.5em 0 0.5em;
+}
+
#interface span.fixity {
color: #919191;
border-left: 1px solid #919191;
@@ -406,30 +427,39 @@ div#style-menu-holder {
margin-top: 0.8em;
}
-.subs dl {
+.clearfix:after {
+ clear: both;
+ content: " ";
+ display: block;
+ height: 0;
+ visibility: hidden;
+}
+
+.subs ul {
+ list-style: none;
+ display: table;
margin: 0;
}
-.subs dt {
- float: left;
- clear: left;
- display: block;
+.subs ul li {
+ display: table-row;
+}
+
+.subs ul li dfn {
+ display: table-cell;
+ font-style: normal;
+ font-weight: bold;
margin: 1px 0;
+ white-space: nowrap;
}
-.subs dd {
- float: right;
- width: 90%;
- display: block;
+.subs ul li > .doc {
+ display: table-cell;
padding-left: 0.5em;
margin-bottom: 0.5em;
}
-.subs dd.empty {
- display: none;
-}
-
-.subs dd p {
+.subs ul li > .doc p {
margin: 0;
}
@@ -445,6 +475,11 @@ div#style-menu-holder {
margin-left: 1em;
}
+/* Workaround for bug in Firefox (issue #384) */
+.inst-left {
+ float: left;
+}
+
.top p.src {
border-top: 1px solid #ccc;
}
diff --git a/haddock-api/resources/html/frames.html b/haddock-api/resources/html/frames.html
index 1b4e38d4..e86edb66 100644
--- a/haddock-api/resources/html/frames.html
+++ b/haddock-api/resources/html/frames.html
@@ -1,4 +1,4 @@
-<!DOCTYPE html
+<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js
index 9a6fccf7..fc7743fe 100644
--- a/haddock-api/resources/html/haddock-util.js
+++ b/haddock-api/resources/html/haddock-util.js
@@ -131,11 +131,11 @@ function perform_search(full)
var text = document.getElementById("searchbox").value.toLowerCase();
if (text == last_search && !full) return;
last_search = text;
-
+
var table = document.getElementById("indexlist");
var status = document.getElementById("searchmsg");
var children = table.firstChild.childNodes;
-
+
// first figure out the first node with the prefix
var first = bisect(-1);
var last = (first == -1 ? -1 : bisect(1));
@@ -166,7 +166,7 @@ function perform_search(full)
status.innerHTML = "";
}
-
+
function setclass(first, last, status)
{
for (var i = first; i <= last; i++)
@@ -174,8 +174,8 @@ function perform_search(full)
children[i].className = status;
}
}
-
-
+
+
// do a binary search, treating 0 as ...
// return either -1 (no 0's found) or location of most far match
function bisect(dir)
@@ -201,9 +201,9 @@ function perform_search(full)
if (checkitem(i) == 0) return i;
}
return -1;
- }
-
-
+ }
+
+
// from an index, decide what the result is
// 0 = match, -1 is lower, 1 is higher
function checkitem(i)
@@ -212,8 +212,8 @@ function perform_search(full)
if (s == text) return 0;
else return (s > text ? -1 : 1);
}
-
-
+
+
// from an index, get its string
// this abstracts over alternates
function getitem(i)
@@ -229,7 +229,7 @@ function perform_search(full)
}
function setSynopsis(filename) {
- if (parent.window.synopsis) {
+ if (parent.window.synopsis && parent.window.synopsis.location) {
if (parent.window.synopsis.location.replace) {
// In Firefox this avoids adding the change to the history.
parent.window.synopsis.location.replace(filename);
@@ -250,7 +250,7 @@ function addMenuItem(html) {
function adjustForFrames() {
var bodyCls;
-
+
if (parent.location.href == window.location.href) {
// not in frames, so add Frames button
addMenuItem("<a href='#' onclick='reframe();return true;'>Frames</a>");
diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js
new file mode 100644
index 00000000..1e903bd0
--- /dev/null
+++ b/haddock-api/resources/html/highlight.js
@@ -0,0 +1,27 @@
+
+var highlight = function (on) {
+ return function () {
+ var links = document.getElementsByTagName('a');
+ for (var i = 0; i < links.length; i++) {
+ var that = links[i];
+
+ if (this.href != that.href) {
+ continue;
+ }
+
+ if (on) {
+ that.classList.add("hover-highlight");
+ } else {
+ that.classList.remove("hover-highlight");
+ }
+ }
+ }
+};
+
+window.onload = function () {
+ var links = document.getElementsByTagName('a');
+ for (var i = 0; i < links.length; i++) {
+ links[i].onmouseover = highlight(true);
+ links[i].onmouseout = highlight(false);
+ }
+};
diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css
new file mode 100644
index 00000000..e83dc5ec
--- /dev/null
+++ b/haddock-api/resources/html/solarized.css
@@ -0,0 +1,55 @@
+body {
+ background-color: #fdf6e3;
+}
+
+.hs-identifier {
+ color: #073642;
+}
+
+.hs-identifier.hs-var {
+}
+
+.hs-identifier.hs-type {
+ color: #5f5faf;
+}
+
+.hs-keyword {
+ color: #af005f;
+}
+
+.hs-string, .hs-char {
+ color: #cb4b16;
+}
+
+.hs-number {
+ color: #268bd2;
+}
+
+.hs-operator {
+ color: #d33682;
+}
+
+.hs-glyph, .hs-special {
+ color: #dc322f;
+}
+
+.hs-comment {
+ color: #8a8a8a;
+}
+
+.hs-pragma {
+ color: #2aa198;
+}
+
+.hs-cpp {
+ color: #859900;
+}
+
+a:link, a:visited {
+ text-decoration: none;
+ border-bottom: 1px solid #eee8d5;
+}
+
+a:hover, a.hover-highlight {
+ background-color: #eee8d5;
+}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 72ec21c8..70cdf8a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Themes (getThemes)
import Haddock.Backends.LaTeX
import Haddock.Backends.Hoogle
+import Haddock.Backends.Hyperlinker
import Haddock.Interface
import Haddock.Parser
import Haddock.Types
@@ -39,11 +40,13 @@ import Haddock.Options
import Haddock.Utils
import Control.Monad hiding (forM_)
+import Control.Applicative
import Data.Foldable (forM_)
import Data.List (isPrefixOf)
import Control.Exception
import Data.Maybe
import Data.IORef
+import Data.Map (Map)
import qualified Data.Map as Map
import System.IO
import System.Exit
@@ -154,6 +157,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
_ -> return flags
unless (Flag_NoWarnings `elem` flags) $ do
+ hypSrcWarnings flags
forM_ (warnings args) $ \warning -> do
hPutStrLn stderr warning
@@ -222,13 +226,16 @@ renderStep dflags flags qual pkgs interfaces = do
let
ifaceFiles = map snd pkgs
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- srcMap = Map.fromList [ (ifUnitId if_, x) | ((_, Just x), if_) <- pkgs ]
- render dflags flags qual interfaces installedIfaces srcMap
+ extSrcMap = Map.fromList $ do
+ ((_, Just path), ifile) <- pkgs
+ iface <- ifInstalledIfaces ifile
+ return (instMod iface, path)
+ render dflags flags qual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags qual ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -239,6 +246,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
opt_index_url = optIndexUrl flags
odir = outputDir flags
opt_latex_style = optLaTeXStyle flags
+ opt_source_css = optSourceCssFile flags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -247,15 +255,35 @@ render dflags flags qual ifaces installedIfaces srcMap = do
allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
pkgMod = ifaceMod (head ifaces)
- pkgKey = moduleUnitId pkgMod
+ pkgKey = moduleUnitId pkgMod
pkgStr = Just (unitIdString pkgKey)
- (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod
+ pkgNameVer = modulePackageInfo dflags flags pkgMod
(srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
- srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
+
+ srcModule'
+ | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
+ | otherwise = srcModule
+
+ srcMap = mkSrcMap $ Map.union
+ (Map.map SrcExternal extSrcMap)
+ (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
+
+ pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap
+ pkgSrcMap'
+ | Flag_HyperlinkedSource `elem` flags =
+ Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
+ | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap
+ | otherwise = pkgSrcMap
+
-- TODO: Get these from the interface files as with srcMap
- srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
- sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
+ pkgSrcLMap'
+ | Flag_HyperlinkedSource `elem` flags =
+ Map.singleton pkgKey hypSrcModuleLineUrlFormat
+ | Just path <- srcLEntity = Map.singleton pkgKey path
+ | otherwise = Map.empty
+
+ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
libDir <- getHaddockLibDir flags
prologue <- getPrologue dflags flags
@@ -285,17 +313,28 @@ render dflags flags qual ifaces installedIfaces srcMap = do
-- TODO: we throw away Meta for both Hoogle and LaTeX right now,
-- might want to fix that if/when these two get some work on them
when (Flag_Hoogle `elem` flags) $ do
- let pkgNameStr | unpackFS pkgNameFS == "main" && title /= []
- = title
- | otherwise = unpackFS pkgNameFS
- where PackageName pkgNameFS = pkgName
- ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces
- odir
+ case pkgNameVer of
+ Nothing -> putStrLn . unlines $
+ [ "haddock: Unable to find a package providing module "
+ ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
+ , ""
+ , " Perhaps try specifying the desired package explicitly"
+ ++ " 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
+ when (Flag_HyperlinkedSource `elem` flags) $ 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
@@ -309,12 +348,12 @@ modulePackageInfo :: DynFlags
-- contain the package name or version
-- provided by the user which we
-- prioritise
- -> Module -> (PackageName, Data.Version.Version)
+ -> Module -> Maybe (PackageName, Data.Version.Version)
modulePackageInfo dflags flags modu =
- (fromMaybe (packageName pkg) (optPackageName flags),
- fromMaybe (packageVersion pkg) (optPackageVersion flags))
+ cmdline <|> pkgDb
where
- pkg = getPackageDetails dflags (moduleUnitId modu)
+ cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
+ pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)
-------------------------------------------------------------------------------
@@ -464,6 +503,35 @@ shortcutFlags flags = do
++ "Ported to use the GHC API by David Waern 2006-2008\n"
+-- | Generate some warnings about potential misuse of @--hyperlinked-source@.
+hypSrcWarnings :: [Flag] -> IO ()
+hypSrcWarnings flags = do
+
+ when (hypSrc && any isSourceUrlFlag flags) $
+ hPutStrLn stderr $ concat
+ [ "Warning: "
+ , "--source-* options are ignored when "
+ , "--hyperlinked-source is enabled."
+ ]
+
+ when (not hypSrc && any isSourceCssFlag flags) $
+ hPutStrLn stderr $ concat
+ [ "Warning: "
+ , "source CSS file is specified but "
+ , "--hyperlinked-source is disabled."
+ ]
+
+ where
+ hypSrc = Flag_HyperlinkedSource `elem` flags
+ isSourceUrlFlag (Flag_SourceBaseURL _) = True
+ isSourceUrlFlag (Flag_SourceModuleURL _) = True
+ isSourceUrlFlag (Flag_SourceEntityURL _) = True
+ isSourceUrlFlag (Flag_SourceLEntityURL _) = True
+ isSourceUrlFlag _ = False
+ isSourceCssFlag (Flag_SourceCss _) = True
+ isSourceCssFlag _ = False
+
+
updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
updateHTMLXRefs packages = do
writeIORef html_xrefs_ref (Map.fromList mapping)
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
index 1c248bfb..0bdc9057 100644
--- a/haddock-api/src/Haddock/Backends/HaddockDB.hs
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -40,7 +40,7 @@ ppIfaces mods
where
do_mod (Module mod, iface)
= text "<sect1 id=\"sec-" <> text mod <> text "\">"
- $$ text "<title><literal>"
+ $$ text "<title><literal>"
<> text mod
<> text "</literal></title>"
$$ text "<indexterm><primary><literal>"
@@ -50,10 +50,10 @@ ppIfaces mods
$$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
$$ text "</variablelist>"
$$ text "</sect1>"
-
+
do_export mod decl | (nm:_) <- declBinders decl
= text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
- $$ text "<term><literal>"
+ $$ text "<term><literal>"
<> do_decl decl
<> text "</literal></term>"
$$ text "<listitem>"
@@ -63,11 +63,11 @@ ppIfaces mods
$$ text "</varlistentry>"
do_export _ _ = empty
- do_decl (HsTypeSig _ [nm] ty _)
+ do_decl (HsTypeSig _ [nm] ty _)
= ppHsName nm <> text " :: " <> ppHsType ty
do_decl (HsTypeDecl _ nm args ty _)
= hsep ([text "type", ppHsName nm ]
- ++ map ppHsName args
+ ++ map ppHsName args
++ [equals, ppHsType ty])
do_decl (HsNewTypeDecl loc ctx nm args con drv _)
= hsep ([text "data", ppHsName nm] -- data, not newtype
@@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc
ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
ppHsName name
<> (braces . hsep . punctuate comma . map ppField $ fieldList)
-ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
hsep (ppHsName name : map ppHsBangType typeList)
ppField (HsFieldDecl ns ty doc)
@@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty
ppHsContext :: HsContext -> Doc
ppHsContext [] = empty
-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
ppHsType :: HsType -> Doc
@@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) =
ppHsType (HsForAllType (Just tvs) [] htype) =
hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
ppHsType (HsForAllType (Just tvs) context htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." :
+ hsep (text "forall" : map ppHsName tvs ++ text "." :
ppHsContext context : text "=>" : [ppHsType htype])
ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
@@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str
ppHsQName n@(Qual (Module mod) str)
| n == unit_con_name = ppHsName str
| isSpecial str = ppHsName str
- | otherwise
+ | otherwise
= text "<link linkend=" <> ppLinkId mod str <> char '>'
<> ppHsName str
<> text "</link>"
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e73192ed..a9bc9a8b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -15,12 +15,15 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-
+import BasicTypes (OverlapFlag(..), OverlapMode(..))
+import InstEnv (ClsInst(..))
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
+
import GHC
import Outputable
+import NameSet
import Data.Char
import Data.List
@@ -88,18 +91,22 @@ dropComment (x:xs) = x : dropComment xs
dropComment [] = []
-out :: Outputable a => DynFlags -> a -> String
-out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
+outWith :: Outputable a => (SDoc -> String) -> a -> [Char]
+outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
where
f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
f (x:xs) = x : f xs
f [] = []
+out :: Outputable a => DynFlags -> a -> String
+out dflags = outWith $ showSDocUnqual dflags
operator :: String -> String
operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
operator x = x
+commaSeparate :: Outputable a => DynFlags -> [a] -> String
+commaSeparate dflags = showSDocUnqual dflags . interpp'SP
---------------------------------------------------------------------
-- How to print each export
@@ -108,38 +115,84 @@ ppExport :: DynFlags -> ExportItem Name -> [String]
ppExport dflags ExportDecl { expItemDecl = L _ decl
, expItemMbDoc = (dc, _)
, expItemSubDocs = subdocs
+ , expItemFixities = fixities
} = ppDocumentation dflags dc ++ f decl
where
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
- f (TyClD d@ClassDecl{}) = ppClass 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
+ f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
+ 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
f _ = []
+
+ ppFixities = concatMap (ppFixity dflags) fixities
ppExport _ _ = []
+ppSigWithDoc :: DynFlags -> Sig Name -> [(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)
+
+ppSigWithDoc _ _ _ = []
ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig)
-ppSig _ _ = []
+ppSig dflags x = ppSigWithDoc dflags x []
-pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String]
-pp_sig dflags names (L _ typ)
- = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
- where
- prettyNames = intercalate ", " $ map (out dflags) names
+pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String
+pp_sig dflags names (L _ typ) =
+ operator prettyNames ++ " :: " ++ outHsType dflags typ
+ where
+ prettyNames = intercalate ", " $ map (out dflags) names
-- note: does not yet output documentation for class methods
-ppClass :: DynFlags -> TyClDecl Name -> [String]
-ppClass dflags x = out dflags x{tcdSigs=[]} :
- concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x)
- where
- add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods
+ where
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x = [dropComment $ out dflags x]
+ ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+ ppSig' = flip (ppSigWithDoc dflags) subdocs
+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
+
+ ppTyFams
+ | null $ tcdATs decl = ""
+ | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
+ [ map ppr (tcdATs decl)
+ , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
+ ]
+
+ whereWrapper elems = vcat'
+ [ text "where" <+> lbrace
+ , nest 4 . vcat . map (<> semi) $ elems
+ , rbrace
+ ]
+
+ tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name
+ tyFamEqnToSyn tfe = SynDecl
+ { tcdLName = tfe_tycon tfe
+ , tcdTyVars = tfe_pats tfe
+ , tcdRhs = tfe_rhs tfe
+ , tcdFVs = emptyNameSet
+ }
+
+
+ppInstance :: DynFlags -> ClsInst -> [String]
+ppInstance dflags x =
+ [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ where
+ -- As per #168, we don't want safety information about the class
+ -- in Hoogle output. The easiest way to achieve this is to set the
+ -- safety information to a state where the Outputable instance
+ -- produces no output which means no overlap and unsafe (or [safe]
+ -- is generated).
+ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty
+ , isSafeOverlap = False } }
ppSynonym :: DynFlags -> TyClDecl Name -> [String]
ppSynonym dflags x = [out dflags x]
@@ -181,7 +234,10 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
apps = foldl1 (\x y -> reL $ HsAppTy x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
- name = out dflags $ map unL $ getConNames con
+
+ -- We print the constructors as comma-separated list. See GHC
+ -- docs for con_names on why it is a list to begin with.
+ name = commaSeparate dflags . map unL $ getConNames con
resType = apps $ map (reL . HsTyVar . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
@@ -195,6 +251,10 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {}
name = out dflags $ map unL $ getConNames con
+ppFixity :: DynFlags -> (Name, Fixity) -> [String]
+ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]
+
+
---------------------------------------------------------------------
-- DOCUMENTATION
@@ -323,3 +383,8 @@ escape = concatMap f
f '>' = "&gt;"
f '&' = "&amp;"
f x = [x]
+
+
+-- | Just like 'vcat' but uses '($+$)' instead of '($$)'.
+vcat' :: [SDoc] -> SDoc
+vcat' = foldr ($+$) empty
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
new file mode 100644
index 00000000..248a8a54
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -0,0 +1,64 @@
+module Haddock.Backends.Hyperlinker
+ ( ppHyperlinkedSource
+ , module Haddock.Backends.Hyperlinker.Types
+ , module Haddock.Backends.Hyperlinker.Utils
+ ) where
+
+
+import Haddock.Types
+import Haddock.Backends.Hyperlinker.Renderer
+import Haddock.Backends.Hyperlinker.Types
+import Haddock.Backends.Hyperlinker.Utils
+
+import Text.XHtml hiding ((</>))
+
+import Data.Maybe
+import System.Directory
+import System.FilePath
+
+
+-- | Generate hyperlinked source for given interfaces.
+--
+-- Note that list of interfaces should also contain interfaces normally hidden
+-- when generating documentation. Otherwise this could lead to dead links in
+-- produced source.
+ppHyperlinkedSource :: FilePath -- ^ Output directory
+ -> FilePath -- ^ Resource directory
+ -> Maybe FilePath -- ^ Custom CSS file path
+ -> Bool -- ^ Flag indicating whether to pretty-print HTML
+ -> SrcMap -- ^ Paths to sources
+ -> [Interface] -- ^ Interfaces for which we create source
+ -> IO ()
+ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
+ createDirectoryIfMissing True srcdir
+ let cssFile = fromMaybe (defaultCssFile libdir) mstyle
+ copyFile cssFile $ srcdir </> srcCssFile
+ copyFile (libdir </> "html" </> highlightScript) $
+ srcdir </> highlightScript
+ mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
+ where
+ srcdir = outdir </> hypSrcDir
+
+-- | Generate hyperlinked source for particular interface.
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
+ -> IO ()
+ppHyperlinkedModuleSource srcdir pretty srcs iface =
+ case ifaceTokenizedSrc iface of
+ Just tokens -> writeFile path . html . render' $ tokens
+ Nothing -> return ()
+ where
+ render' = render (Just srcCssFile) (Just highlightScript) srcs
+ html = if pretty then renderHtml else showHtml
+ path = srcdir </> hypSrcModuleFile (ifaceMod iface)
+
+-- | Name of CSS file in output directory.
+srcCssFile :: FilePath
+srcCssFile = "style.css"
+
+-- | Name of highlight script in output and resource directory.
+highlightScript :: FilePath
+highlightScript = "highlight.js"
+
+-- | Path to default CSS file.
+defaultCssFile :: FilePath -> FilePath
+defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
new file mode 100644
index 00000000..1f396df5
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+
+module Haddock.Backends.Hyperlinker.Ast (enrich) where
+
+
+import Haddock.Syb
+import Haddock.Backends.Hyperlinker.Types
+
+import qualified GHC
+
+import Control.Applicative
+import Data.Data
+import Data.Maybe
+
+
+-- | Add more detailed information to token stream using GHC API.
+enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
+enrich src =
+ map $ \token -> RichToken
+ { rtkToken = token
+ , rtkDetails = enrichToken token detailsMap
+ }
+ where
+ detailsMap = concatMap ($ src)
+ [ variables
+ , types
+ , decls
+ , binds
+ , imports
+ ]
+
+-- | A map containing association between source locations and "details" of
+-- this location.
+--
+-- For the time being, it is just a list of pairs. However, looking up things
+-- in such structure has linear complexity. We cannot use any hashmap-like
+-- stuff because source locations are not ordered. In the future, this should
+-- be replaced with interval tree data structure.
+type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
+
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+
+enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
+enrichToken (Token typ _ spn) dm
+ | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
+enrichToken _ _ = Nothing
+
+-- | Obtain details map for variables ("normally" used identifiers).
+variables :: GHC.RenamedSource -> DetailsMap
+variables =
+ everything (<|>) (var `combine` rec)
+ where
+ var term = case cast term of
+ (Just (GHC.L sspan (GHC.HsVar name))) ->
+ pure (sspan, RtkVar (GHC.unLoc name))
+ (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
+ pure (sspan, RtkVar name)
+ _ -> empty
+ rec term = case cast term of
+ Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->
+ pure (sspan, RtkVar name)
+ _ -> empty
+
+-- | Obtain details map for types.
+types :: GHC.RenamedSource -> DetailsMap
+types =
+ everything (<|>) ty
+ where
+ ty term = case cast term of
+ (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+ pure (sspan, RtkType (GHC.unLoc name))
+ _ -> empty
+
+-- | Obtain details map for identifier bindings.
+--
+-- That includes both identifiers bound by pattern matching or declared using
+-- ordinary assignment (in top-level declarations, let-expressions and where
+-- clauses).
+binds :: GHC.RenamedSource -> DetailsMap
+binds =
+ everything (<|>) (fun `combine` pat `combine` tvar)
+ where
+ fun term = case cast term of
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+ pure (sspan, RtkBind name)
+ _ -> empty
+ pat term = case cast term of
+ (Just (GHC.L sspan (GHC.VarPat name))) ->
+ pure (sspan, RtkBind (GHC.unLoc name))
+ (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
+ [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+ (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
+ pure (sspan, RtkBind name)
+ _ -> empty
+ rec term = case cast term of
+ (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
+ pure (sspan, RtkVar name)
+ _ -> empty
+ tvar term = case cast term of
+ (Just (GHC.L sspan (GHC.UserTyVar name))) ->
+ pure (sspan, RtkBind (GHC.unLoc name))
+ (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
+ pure (sspan, RtkBind name)
+ _ -> empty
+
+-- | Obtain details map for top-level declarations.
+decls :: GHC.RenamedSource -> DetailsMap
+decls (group, _, _, _) = concatMap ($ group)
+ [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+ , everything (<|>) fun . GHC.hs_valds
+ , everything (<|>) (con `combine` ins)
+ ]
+ where
+ typ (GHC.L _ t) = case t of
+ GHC.DataDecl 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
+ fun term = case cast term of
+ (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
+ | GHC.isExternalName name -> pure (sspan, RtkDecl name)
+ _ -> empty
+ con term = case cast term of
+ (Just cdcl) ->
+ map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
+ Nothing -> empty
+ ins term = case cast term of
+ (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
+ (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->
+ pure . tyref $ GHC.tfe_tycon eqn
+ _ -> empty
+ fld term = case cast term of
+ Just (field :: GHC.ConDeclField GHC.Name)
+ -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
+ Nothing -> empty
+ sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
+ sig _ = []
+ decl (GHC.L sspan name) = (sspan, RtkDecl name)
+ tyref (GHC.L sspan name) = (sspan, RtkType name)
+
+-- | Obtain details map for import declarations.
+--
+-- This map also includes type and variable details for items in export and
+-- import lists.
+imports :: GHC.RenamedSource -> DetailsMap
+imports src@(_, imps, _, _) =
+ everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
+ where
+ ie term = case cast term of
+ (Just (GHC.IEVar v)) -> pure $ var v
+ (Just (GHC.IEThingAbs t)) -> pure $ typ t
+ (Just (GHC.IEThingAll t)) -> pure $ typ t
+ (Just (GHC.IEThingWith t _ vs _fls)) ->
+ [typ t] ++ map var vs
+ _ -> 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
+
+-- | Check whether token stream span matches GHC source span.
+--
+-- Currently, it is implemented as checking whether "our" span is contained
+-- in GHC span. The reason for that is because GHC span are generally wider
+-- and may spread across couple tokens. For example, @(>>=)@ consists of three
+-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable
+-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@
+-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span
+-- associated with @quux@ contains all five elements.
+matches :: Span -> GHC.SrcSpan -> Bool
+matches tspan (GHC.RealSrcSpan aspan)
+ | saspan <= stspan && etspan <= easpan = True
+ where
+ stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)
+ etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)
+ saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
+ easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
+matches _ _ = False
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
new file mode 100644
index 00000000..e206413e
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -0,0 +1,204 @@
+module Haddock.Backends.Hyperlinker.Parser (parse) where
+
+
+import Data.Char
+import Data.List
+import Data.Maybe
+
+import Haddock.Backends.Hyperlinker.Types
+
+
+-- | Turn source code string into a stream of more descriptive tokens.
+--
+-- Result should retain original file layout (including comments, whitespace,
+-- etc.), i.e. the following "law" should hold:
+--
+-- @concat . map 'tkValue' . 'parse' = id@
+parse :: String -> [Token]
+parse = tokenize . tag . chunk
+
+-- | Split raw source string to more meaningful chunks.
+--
+-- This is the initial stage of tokenization process. Each chunk is either
+-- a comment (including comment delimiters), a whitespace string, preprocessor
+-- macro (and all its content until the end of a line) or valid Haskell lexeme.
+chunk :: String -> [String]
+chunk [] = []
+chunk str@(c:_)
+ | isSpace c =
+ let (space, mcpp, rest) = spanSpaceOrCpp str
+ in [space] ++ maybeToList mcpp ++ chunk rest
+chunk str
+ | "--" `isPrefixOf` str = chunk' $ spanToNewline str
+ | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
+ | otherwise = case lex str of
+ (tok:_) -> chunk' tok
+ [] -> [str]
+ where
+ chunk' (c, rest) = c:(chunk rest)
+
+-- | Split input to "first line" string and the rest of it.
+--
+-- Ideally, this should be done simply with @'break' (== '\n')@. However,
+-- Haskell also allows line-unbreaking (or whatever it is called) so things
+-- are not as simple and this function deals with that.
+spanToNewline :: String -> (String, String)
+spanToNewline [] = ([], [])
+spanToNewline ('\\':'\n':str) =
+ let (str', rest) = spanToNewline str
+ in ('\\':'\n':str', rest)
+spanToNewline str@('\n':_) = ("", str)
+spanToNewline (c:str) =
+ let (str', rest) = spanToNewline str
+ in (c:str', rest)
+
+-- | Split input to whitespace string, (optional) preprocessor directive and
+-- the rest of it.
+--
+-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input
+-- to whitespace. The problem is with /#/ symbol - if it is placed at the very
+-- beginning of a line, it should be recognized as preprocessor macro. In any
+-- other case, it is ordinary Haskell symbol and can be used to declare
+-- operators. Hence, while dealing with whitespace we also check whether there
+-- happens to be /#/ symbol just after a newline character - if that is the
+-- case, we begin treating the whole line as preprocessor macro.
+spanSpaceOrCpp :: String -> (String, Maybe String, String)
+spanSpaceOrCpp ('\n':'#':str) =
+ let (str', rest) = spanToNewline str
+ in ("\n", Just $ '#':str', rest)
+spanSpaceOrCpp (c:str')
+ | isSpace c =
+ let (space, mcpp, rest) = spanSpaceOrCpp str'
+ in (c:space, mcpp, rest)
+spanSpaceOrCpp str = ("", Nothing, str)
+
+-- | Split input to comment content (including delimiters) and the rest.
+--
+-- Again, some more logic than simple 'span' is required because of Haskell
+-- comment nesting policy.
+chunkComment :: Int -> String -> (String, String)
+chunkComment _ [] = ("", "")
+chunkComment depth ('{':'-':str) =
+ let (c, rest) = chunkComment (depth + 1) str
+ in ("{-" ++ c, rest)
+chunkComment depth ('-':'}':str)
+ | depth == 1 = ("-}", str)
+ | otherwise =
+ let (c, rest) = chunkComment (depth - 1) str
+ in ("-}" ++ c, rest)
+chunkComment depth (e:str) =
+ let (c, rest) = chunkComment depth str
+ in (e:c, rest)
+
+-- | Assign source location for each chunk in given stream.
+tag :: [String] -> [(Span, String)]
+tag =
+ reverse . snd . foldl aux (Position 1 1, [])
+ where
+ aux (pos, cs) str =
+ let pos' = foldl move pos str
+ in (pos', (Span pos pos', str):cs)
+ move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
+ move pos _ = pos { posCol = posCol pos + 1 }
+
+-- | Turn unrecognised chunk stream to more descriptive token stream.
+tokenize :: [(Span, String)] -> [Token]
+tokenize =
+ map aux
+ where
+ aux (sp, str) = Token
+ { tkType = classify str
+ , tkValue = str
+ , tkSpan = sp
+ }
+
+-- | Classify given string as appropriate Haskell token.
+--
+-- This method is based on Haskell 98 Report lexical structure description:
+-- https://www.haskell.org/onlinereport/lexemes.html
+--
+-- However, this is probably far from being perfect and most probably does not
+-- handle correctly all corner cases.
+classify :: String -> TokenType
+classify str
+ | "--" `isPrefixOf` str = TkComment
+ | "{-#" `isPrefixOf` str = TkPragma
+ | "{-" `isPrefixOf` str = TkComment
+classify str@(c:_)
+ | isSpace c = TkSpace
+ | isDigit c = TkNumber
+ | c `elem` special = TkSpecial
+ | str `elem` glyphs = TkGlyph
+ | all (`elem` symbols) str = TkOperator
+ | c == '#' = TkCpp
+ | c == '"' = TkString
+ | c == '\'' = TkChar
+classify str
+ | str `elem` keywords = TkKeyword
+ | isIdentifier str = TkIdentifier
+ | otherwise = TkUnknown
+
+keywords :: [String]
+keywords =
+ [ "as"
+ , "case"
+ , "class"
+ , "data"
+ , "default"
+ , "deriving"
+ , "do"
+ , "else"
+ , "hiding"
+ , "if"
+ , "import"
+ , "in"
+ , "infix"
+ , "infixl"
+ , "infixr"
+ , "instance"
+ , "let"
+ , "module"
+ , "newtype"
+ , "of"
+ , "qualified"
+ , "then"
+ , "type"
+ , "where"
+ , "forall"
+ , "family"
+ , "mdo"
+ ]
+
+glyphs :: [String]
+glyphs =
+ [ ".."
+ , ":"
+ , "::"
+ , "="
+ , "\\"
+ , "|"
+ , "<-"
+ , "->"
+ , "@"
+ , "~"
+ , "~#"
+ , "=>"
+ , "-"
+ , "!"
+ ]
+
+special :: [Char]
+special = "()[]{},;`"
+
+-- TODO: Add support for any Unicode symbol or punctuation.
+-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators
+symbols :: [Char]
+symbols = "!#$%&*+./<=>?@\\^|-~:"
+
+isIdentifier :: String -> Bool
+isIdentifier (s:str)
+ | (isLower' s || isUpper s) && all isAlphaNum' str = True
+ where
+ isLower' c = isLower c || c == '_'
+ isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''
+isIdentifier _ = False
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
new file mode 100644
index 00000000..15793f0c
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Haddock.Backends.Hyperlinker.Renderer (render) where
+
+
+import Haddock.Backends.Hyperlinker.Types
+import Haddock.Backends.Hyperlinker.Utils
+
+import qualified GHC
+import qualified Name as GHC
+import qualified Unique as GHC
+
+import System.FilePath.Posix ((</>))
+
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Map as Map
+
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Html
+
+
+type StyleClass = String
+
+
+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
+ where
+ hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
+
+
+header :: Maybe FilePath -> Maybe FilePath -> Html
+header mcss mjs
+ | isNothing mcss && isNothing mjs = Html.noHtml
+header mcss mjs =
+ Html.header $ css mcss <> js mjs
+ where
+ css Nothing = Html.noHtml
+ css (Just cssFile) = Html.thelink Html.noHtml !
+ [ Html.rel "stylesheet"
+ , Html.thetype "text/css"
+ , Html.href cssFile
+ ]
+ js Nothing = Html.noHtml
+ js (Just scriptFile) = Html.script Html.noHtml !
+ [ Html.thetype "text/javascript"
+ , Html.src scriptFile
+ ]
+
+
+tokenGroup :: SrcMap -> TokenGroup -> Html
+tokenGroup _ (GrpNormal tok@(Token { .. }))
+ | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
+ | otherwise = tokenSpan tok ! attrs
+ 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
+
+
+richTokenStyle :: TokenDetails -> [StyleClass]
+richTokenStyle (RtkVar _) = ["hs-var"]
+richTokenStyle (RtkType _) = ["hs-type"]
+richTokenStyle _ = []
+
+tokenStyle :: TokenType -> [StyleClass]
+tokenStyle TkIdentifier = ["hs-identifier"]
+tokenStyle TkKeyword = ["hs-keyword"]
+tokenStyle TkString = ["hs-string"]
+tokenStyle TkChar = ["hs-char"]
+tokenStyle TkNumber = ["hs-number"]
+tokenStyle TkOperator = ["hs-operator"]
+tokenStyle TkGlyph = ["hs-glyph"]
+tokenStyle TkSpecial = ["hs-special"]
+tokenStyle TkSpace = []
+tokenStyle TkComment = ["hs-comment"]
+tokenStyle TkCpp = ["hs-cpp"]
+tokenStyle TkPragma = ["hs-pragma"]
+tokenStyle TkUnknown = []
+
+multiclass :: [StyleClass] -> HtmlAttr
+multiclass = Html.theclass . intercalate " "
+
+externalAnchor :: TokenDetails -> Html -> Html
+externalAnchor (RtkDecl name) content =
+ Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
+externalAnchor _ content = content
+
+internalAnchor :: TokenDetails -> Html -> Html
+internalAnchor (RtkBind name) content =
+ Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
+internalAnchor _ content = content
+
+externalAnchorIdent :: GHC.Name -> String
+externalAnchorIdent = hypSrcNameUrl
+
+internalAnchorIdent :: GHC.Name -> String
+internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
+
+hyperlink :: SrcMap -> TokenDetails -> Html -> Html
+hyperlink srcs details = case rtkName details of
+ Left name ->
+ if GHC.isInternalName name
+ then internalHyperlink name
+ else externalNameHyperlink srcs name
+ Right name -> externalModHyperlink srcs name
+
+internalHyperlink :: GHC.Name -> Html -> Html
+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
+ Just SrcLocal -> Html.anchor content !
+ [ Html.href $ hypSrcModuleNameUrl mdl name ]
+ Just (SrcExternal path) -> Html.anchor content !
+ [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
+ Nothing -> content
+ where
+ 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 !
+ [ Html.href $ hypSrcModuleUrl' name ]
+ Just (SrcExternal path) -> Html.anchor content !
+ [ Html.href $ path </> hypSrcModuleUrl' name ]
+ Nothing -> content
+
+
+renderSpace :: Int -> String -> Html
+renderSpace _ [] = Html.noHtml
+renderSpace line ('\n':rest) = mconcat
+ [ Html.thespan . Html.toHtml $ "\n"
+ , lineAnchor (line + 1)
+ , renderSpace (line + 1) rest
+ ]
+renderSpace line space =
+ let (hspace, rest) = span (/= '\n') space
+ in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest
+
+
+lineAnchor :: Int -> Html
+lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
new file mode 100644
index 00000000..5f4dbc8c
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -0,0 +1,85 @@
+module Haddock.Backends.Hyperlinker.Types where
+
+
+import qualified GHC
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+
+data Token = Token
+ { tkType :: TokenType
+ , tkValue :: String
+ , tkSpan :: Span
+ }
+
+data Position = Position
+ { posRow :: !Int
+ , posCol :: !Int
+ }
+
+data Span = Span
+ { spStart :: Position
+ , spEnd :: Position
+ }
+
+data TokenType
+ = TkIdentifier
+ | TkKeyword
+ | TkString
+ | TkChar
+ | TkNumber
+ | TkOperator
+ | TkGlyph
+ | TkSpecial
+ | TkSpace
+ | TkComment
+ | TkCpp
+ | TkPragma
+ | TkUnknown
+ deriving (Show, Eq)
+
+
+data RichToken = RichToken
+ { rtkToken :: Token
+ , rtkDetails :: Maybe TokenDetails
+ }
+
+data TokenDetails
+ = RtkVar GHC.Name
+ | RtkType GHC.Name
+ | RtkBind GHC.Name
+ | RtkDecl GHC.Name
+ | RtkModule GHC.ModuleName
+ deriving (Eq)
+
+
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
+
+
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+ = SrcExternal FilePath
+ | 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)
+
+mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
+mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
new file mode 100644
index 00000000..9de4a03d
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -0,0 +1,68 @@
+module Haddock.Backends.Hyperlinker.Utils
+ ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
+ , hypSrcModuleUrl, hypSrcModuleUrl'
+ , hypSrcNameUrl
+ , hypSrcLineUrl
+ , hypSrcModuleNameUrl, hypSrcModuleLineUrl
+ , hypSrcModuleUrlFormat
+ , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
+ ) where
+
+
+import Haddock.Backends.Xhtml.Utils
+
+import GHC
+import FastString
+import System.FilePath.Posix ((</>))
+
+
+hypSrcDir :: FilePath
+hypSrcDir = "src"
+
+hypSrcModuleFile :: Module -> FilePath
+hypSrcModuleFile = hypSrcModuleFile' . moduleName
+
+hypSrcModuleFile' :: ModuleName -> FilePath
+hypSrcModuleFile' mdl = spliceURL'
+ Nothing (Just mdl) Nothing Nothing moduleFormat
+
+hypSrcModuleUrl :: Module -> String
+hypSrcModuleUrl = hypSrcModuleFile
+
+hypSrcModuleUrl' :: ModuleName -> String
+hypSrcModuleUrl' = hypSrcModuleFile'
+
+hypSrcNameUrl :: Name -> String
+hypSrcNameUrl name = spliceURL
+ Nothing Nothing (Just name) Nothing nameFormat
+
+hypSrcLineUrl :: Int -> String
+hypSrcLineUrl line = spliceURL
+ Nothing Nothing Nothing (Just spn) lineFormat
+ where
+ loc = mkSrcLoc nilFS line 1
+ spn = mkSrcSpan loc loc
+
+hypSrcModuleNameUrl :: Module -> Name -> String
+hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
+
+hypSrcModuleLineUrl :: Module -> Int -> String
+hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
+
+hypSrcModuleUrlFormat :: String
+hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
+
+hypSrcModuleNameUrlFormat :: String
+hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
+
+hypSrcModuleLineUrlFormat :: String
+hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
+
+moduleFormat :: String
+moduleFormat = "%{MODULE}.html"
+
+nameFormat :: String
+nameFormat = "%{NAME}"
+
+lineFormat :: String
+lineFormat = "line-%{LINE}"
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e9cc3f83..ab6bb41c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.LaTeX
@@ -24,10 +25,9 @@ import qualified Pretty
import GHC
import OccName
import Name ( nameOccName )
-import RdrName ( rdrNameOcc, mkRdrUnqual )
+import RdrName ( rdrNameOcc )
import FastString ( unpackFS, unpackLitString, zString )
import Outputable ( panic)
-import PrelNames ( mkUnboundName )
import qualified Data.Map as Map
import System.Directory
@@ -528,14 +528,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 DocName -> LaTeX
-ppDocInstance unicode (instHead, doc) =
+ppDocInstance unicode (instHead, doc, _) =
declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
@@ -544,12 +544,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
-ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode
- <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
-ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
- error "data instances not supported by --latex yet"
+ppInstHead unicode (InstHead {..}) = case ihdInstType of
+ ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
+ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
+ DataInst _ -> error "data instances not supported by --latex yet"
+ where
+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+ tibody = maybe empty (\t -> equals <+> ppType unicode t)
lookupAnySubdoc :: (Eq name1) =>
name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 31757eeb..1554a33c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -36,7 +36,6 @@ import Haddock.GhcUtils
import Control.Monad ( when, unless )
import Data.Char ( toUpper )
-import Data.Functor ( (<$>) )
import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )
import Data.Maybe
import System.FilePath hiding ( (</>) )
@@ -547,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
synopsis
| no_doc_at_all = noHtml
| otherwise
- = divSynposis $
+ = divSynopsis $
paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
shortDeclList (
mapMaybe (processExport True linksInfo unicode qual) exports
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d54f4e16..49149b8c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE TransformListComp #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.Decl
@@ -18,7 +20,6 @@ module Haddock.Backends.Xhtml.Decl (
tyvarNames
) where
-
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
@@ -28,7 +29,6 @@ import Haddock.GhcUtils
import Haddock.Types
import Haddock.Doc (combineDocumentation)
-import Control.Applicative
import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
@@ -38,8 +38,7 @@ import GHC
import GHC.Exts
import Name
import BooleanFormula
-import RdrName ( rdrNameOcc, mkRdrUnqual )
-import PrelNames ( mkUnboundName )
+import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -220,11 +219,32 @@ ppTyName :: Name -> Html
ppTyName = ppName Prefix
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan
+ -> [DocName] -> HsType DocName
+ -> Html
+ppSimpleSig links splice unicode qual loc names typ =
+ topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
+ where
+ topDeclElem' = topDeclElem links loc splice
+ ppTyp = ppType unicode qual typ
+ occNames = map getOccName names
+
+
--------------------------------------------------------------------------------
-- * Type families
--------------------------------------------------------------------------------
+ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html
+ppFamilyInfo assoc OpenTypeFamily
+ | assoc = keyword "type"
+ | otherwise = keyword "type family"
+ppFamilyInfo assoc DataFamily
+ | assoc = keyword "data"
+ | otherwise = keyword "data family"
+ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
+
+
ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
-> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
@@ -243,18 +263,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
) <+>
ppFamDeclBinderWithVars summary d <+>
-
- (case result of
- NoSig -> noHtml
- KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- ) <+>
+ ppResultSig result unicode qual <+>
(case injectivity of
Nothing -> noHtml
Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
)
+ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+ NoSig -> noHtml
+ KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+
+ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
+ -> Html
+ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
+ ppFamilyInfo True pfdInfo <+>
+ ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
+ ppResultSig (unLoc pfdKindSig) unicode qual
ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
@@ -282,7 +309,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
| otherwise
- = ppInstances instances docname unicode qual
+ = ppInstances links (OriginFamily docname) instances splice unicode qual
-- Individual equation of a closed type family
ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -291,6 +318,18 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
<+> equals <+> ppType unicode qual (unLoc rhs)
, Nothing, [] )
+
+
+ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
+ -> PseudoFamilyDecl DocName
+ -> Html
+ppPseudoFamilyDecl links splice unicode qual
+ decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
+ wrapper $ ppPseudoFamilyHeader unicode qual decl
+ where
+ wrapper = topDeclElem links loc splice [name]
+
+
--------------------------------------------------------------------------------
-- * Associated Types
--------------------------------------------------------------------------------
@@ -450,6 +489,8 @@ ppClassDecl summary links instances fixities loc d subdocs
| otherwise = classheader +++ docSection Nothing qual d
+++ minimalBit +++ atBit +++ methodBit +++ instancesBit
where
+ sigs = map unLoc lsigs
+
classheader
| any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
| otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
@@ -480,10 +521,10 @@ ppClassDecl summary links instances fixities loc d subdocs
-- there are different subdocs for different names in a single
-- type signature?
- minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of
+ minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
- sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+ sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
@@ -503,31 +544,93 @@ ppClassDecl summary links instances fixities loc d subdocs
where wrap | p = parens | otherwise = id
ppMinimal p (Parens x) = ppMinimal p (unLoc x)
- instancesBit = ppInstances instances nm unicode qual
+ instancesBit = ppInstances links (OriginClass nm) instances
+ splice unicode qual
ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
- = subInstances qual instName (map instDecl instances)
+ppInstances :: LinksInfo
+ -> InstOrigin DocName -> [DocInstance DocName]
+ -> Splice -> Unicode -> Qualification
+ -> Html
+ppInstances links origin instances splice unicode qual
+ = subInstances qual instName links True (zipWith instDecl [1..] instances)
+ -- force Splice = True to use line URLs
+ where
+ instName = getOccString origin
+ instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+ instDecl no (inst, mdoc, loc) =
+ ((ppInstHead links splice unicode qual mdoc origin no inst), loc)
+
+
+ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
+ -> Maybe (MDoc DocName)
+ -> InstOrigin DocName -> Int -> InstHead DocName
+ -> SubDecl
+ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
+ case ihdInstType of
+ ClassInst { .. } ->
+ ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
+ , mdoc
+ , [subInstDetails iid ats sigs]
+ )
+ where
+ iid = instanceId origin no ihd
+ sigs = ppInstanceSigs links splice unicode qual clsiSigs
+ ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
+ TypeInst rhs ->
+ (ptype, mdoc, [])
+ where
+ ptype = keyword "type" <+> typ <+> prhs
+ prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+ DataInst dd ->
+ (pdata, mdoc, [])
+ where
+ pdata = keyword "data" <+> typ <+> pdecl
+ pdecl = ppShortDataDecl False True dd unicode qual
+ where
+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+
+
+ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
+ -> [PseudoFamilyDecl DocName]
+ -> [Html]
+ppInstanceAssocTys links splice unicode qual =
+ map ppFamilyDecl'
where
- instName = getOccString $ getName baseName
- instDecl :: DocInstance DocName -> SubDecl
- instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
- <+> ppAppNameTypes n ks ts unicode qual
- instHead (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode qual
- <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
- instHead (n, ks, ts, DataInst dd) = keyword "data"
- <+> ppAppNameTypes n ks ts unicode qual
- <+> ppShortDataDecl False True dd unicode qual
+ ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
+
+
+ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
+ -> [Sig DocName]
+ -> [Html]
+ppInstanceSigs links splice unicode qual sigs = do
+ TypeSig lnames typ <- sigs
+ let names = map unLoc lnames
+ L loc rtyp = get_type typ
+ return $ ppSimpleSig links splice unicode qual loc names rtyp
+ where
+ get_type = hswc_body . hsib_body
+
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
+instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String
+instanceId origin no ihd = concat
+ [ qual origin
+ , ":" ++ getOccString origin
+ , ":" ++ (occNameString . getOccName . ihdClsName) ihd
+ , ":" ++ show no
+ ]
+ where
+ qual (OriginClass _) = "ic"
+ qual (OriginData _) = "id"
+ qual (OriginFamily _) = "if"
+
+
-------------------------------------------------------------------------------
-- * Data & newtype declarations
-------------------------------------------------------------------------------
@@ -595,7 +698,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (getConNames (unLoc c)))) fixities
]
- instancesBit = ppInstances instances docname unicode qual
+ instancesBit = ppInstances links (OriginData docname) instances
+ splice unicode qual
@@ -862,8 +966,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
-- placeholder in the signature, which is followed by the field
-- declarations.
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
@@ -878,7 +982,12 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
where
- ppr_op = ppLDocName qual Infix op
+ -- `(:)` is valid in type signature only as constructor to promoted list
+ -- and needs to be quoted in code so we explicitly quote it here too.
+ ppr_op
+ | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'
+ | otherwise = ppr_op'
+ ppr_op' = ppLDocName qual Infix op
ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
-- = parens (ppr_mono_lty pREC_TOP ty)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 96d734eb..3fe74a82 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup (
docElement, docSection, docSection_,
) where
-import Control.Applicative ((<$>))
-
import Data.List
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
@@ -64,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
then anchor ! [href url]
<< fromMaybe url mLabel
else toHtml $ fromMaybe url mLabel,
- markupAName = \aname -> namedAnchor aname << "",
+ markupAName = \aname
+ -> if insertAnchors
+ then namedAnchor aname << ""
+ else noHtml,
markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
markupProperty = pre . toHtml,
markupExample = examplesToHtml,
@@ -160,8 +161,9 @@ hackMarkup fmt' h' =
UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
CollapsingHeader (Header lvl titl) par n nm ->
let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
- col' = collapseControl id_ True "caption"
- instTable = (thediv ! collapseSection id_ False [] <<)
+ expanded = False
+ col' = collapseControl id_ expanded "caption"
+ instTable = (thediv ! collapseSection id_ expanded [] <<)
lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
getHeader = fromMaybe caption (lookup lvl lvs)
subCaption = getHeader ! col' << markup fmt titl
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index f1f109c5..d24ed9c4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout (
miniBody,
divPackageHeader, divContent, divModuleHeader, divFooter,
- divTableOfContents, divDescription, divSynposis, divInterface,
+ divTableOfContents, divDescription, divSynopsis, divInterface,
divIndex, divAlphabet, divModuleList,
sectionName,
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
subConstructors,
subEquations,
subFields,
- subInstances,
+ subInstances, subInstHead, subInstDetails,
subMethods,
subMinimal,
@@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId)
-
import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, p, quote )
@@ -77,7 +76,7 @@ nonEmptySectionName c
divPackageHeader, divContent, divModuleHeader, divFooter,
- divTableOfContents, divDescription, divSynposis, divInterface,
+ divTableOfContents, divDescription, divSynopsis, divInterface,
divIndex, divAlphabet, divModuleList
:: Html -> Html
@@ -87,7 +86,7 @@ divModuleHeader = sectionDiv "module-header"
divFooter = sectionDiv "footer"
divTableOfContents = sectionDiv "table-of-contents"
divDescription = sectionDiv "description"
-divSynposis = sectionDiv "synopsis"
+divSynopsis = sectionDiv "synopsis"
divInterface = sectionDiv "interface"
divIndex = sectionDiv "index"
divAlphabet = sectionDiv "alphabet"
@@ -128,14 +127,12 @@ divSubDecls cssClass captionName = maybe noHtml wrap
subDlist :: Qualification -> [SubDecl] -> Maybe Html
subDlist _ [] = Nothing
-subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+subDlist qual decls = Just $ ulist << map subEntry decls
where
subEntry (decl, mdoc, subs) =
- dterm ! [theclass "src"] << decl
- +++
- docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs)
-
- clearDiv = thediv ! [ theclass "clear" ] << noHtml
+ li <<
+ (define ! [theclass "src"] << decl +++
+ docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))
subTable :: Qualification -> [SubDecl] -> Maybe Html
@@ -149,6 +146,22 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
: 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)
+ 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
+ )
+ : map (cell . (td <<)) subs
+ linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn
+ linkHtml _ _ = noHtml
+
subBlock :: [Html] -> Maybe Html
subBlock [] = Nothing
subBlock hs = Just $ toHtml hs
@@ -174,17 +187,43 @@ subEquations :: Qualification -> [SubDecl] -> Html
subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+-- | Generate sub table for instance declarations, with source
subInstances :: Qualification
-> String -- ^ Class name, used for anchor generation
- -> [SubDecl] -> Html
-subInstances qual nm = maybe noHtml wrap . instTable
+ -> LinksInfo -> Bool
+ -> [(SubDecl,Located DocName)] -> Html
+subInstances qual nm lnks splice = maybe noHtml wrap . instTable
where
wrap = (subSection <<) . (subCaption +++)
- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice
subSection = thediv ! [theclass "subs instances"]
subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
id_ = makeAnchorId $ "i:" ++ nm
+
+subInstHead :: String -- ^ Instance unique id (for anchor generation)
+ -> Html -- ^ Header content (instance name and type)
+ -> Html
+subInstHead iid hdr =
+ expander noHtml <+> hdr
+ where
+ expander = thespan ! collapseControl (instAnchorId iid) False "instance"
+
+
+subInstDetails :: String -- ^ Instance unique id (for anchor generation)
+ -> [Html] -- ^ Associated type contents
+ -> [Html] -- ^ Method contents (pretty-printed signatures)
+ -> Html
+subInstDetails iid ats mets =
+ section << (subAssociatedTypes ats <+> subMethods mets)
+ where
+ section = thediv ! collapseSection (instAnchorId iid) False "inst-details"
+
+
+instAnchorId :: String -> String
+instAnchorId iid = makeAnchorId $ "i:" ++ iid
+
+
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
@@ -200,12 +239,19 @@ declElem = paragraph ! [theclass "src"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
- declElem << (html <+> srcLink <+> wikiLink)
+topDeclElem lnks loc splice names html =
+ declElem << (html <+> (links lnks loc splice $ head names))
+ -- FIXME: is it ok to simply take the first name?
+
+-- | Adds a source and wiki link at the right hand side of the box.
+-- Name must be documented, otherwise we wouldn't get here.
+links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =
+ (srcLink <+> wikiLink)
where srcLink = let nameUrl = Map.lookup origPkg sourceMap
lineUrl = Map.lookup origPkg lineMap
mUrl | splice = lineUrl
- -- Use the lineUrl as a backup
+ -- Use the lineUrl as a backup
| otherwise = maybe lineUrl Just nameUrl in
case mUrl of
Nothing -> noHtml
@@ -227,10 +273,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm
origMod = nameModule n
origPkg = moduleUnitId origMod
- -- Name must be documented, otherwise we wouldn't get here
- Documented n mdl = head names
- -- FIXME: is it ok to simply take the first name?
-
fname = case loc of
- RealSrcSpan l -> unpackFS (srcSpanFile l)
- UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+ RealSrcSpan l -> unpackFS (srcSpanFile l)
+ UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
+links _ _ _ _ = noHtml
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index cf12da40..c69710d1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri
ppBinder :: Bool -> OccName -> Html
--- The Bool indicates whether we are generating the summary, in which case
--- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n
-ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' Prefix n
+ppBinder = ppBinderWith Prefix
ppBinderInfix :: Bool -> OccName -> Html
-ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n
-ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' Infix n
+ppBinderInfix = ppBinderWith Infix
+
+ppBinderWith :: Notation -> Bool -> OccName -> Html
+-- 'isRef' indicates whether this is merely a reference from another part of
+-- the documentation or is the actual definition; in the latter case, we also
+-- set the 'id' and 'class' attributes.
+ppBinderWith notation isRef n =
+ linkedAnchor name ! attributes << ppBinder' notation n
+ where
+ name = nameAnchorId n
+ attributes | isRef = []
+ | otherwise = [identifier name, theclass "def"]
ppBinder' :: Notation -> OccName -> Html
ppBinder' notation n = wrapInfix notation n $ ppOccName n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
index 79b093ec..10d6ab10 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes (
import Haddock.Options
-import Control.Applicative
import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Either (lefts, rights)
@@ -206,4 +205,3 @@ liftEither f = either Left (Right . f)
concatEither :: [Either a [b]] -> Either a [b]
concatEither = liftEither concat . sequenceEither
-
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index cbcbbd6d..98ff4007 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -14,14 +14,14 @@ module Haddock.Backends.Xhtml.Utils (
renderToString,
namedAnchor, linkedAnchor,
- spliceURL,
+ spliceURL, spliceURL',
groupId,
(<+>), (<=>), char,
keyword, punctuate,
braces, brackets, pabrackets, parens, parenList, ubxParenList,
- arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
+ arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
hsep, vcat,
@@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils (
) where
-import Haddock.GhcUtils
import Haddock.Utils
import Data.Maybe
@@ -38,18 +37,31 @@ import Text.XHtml hiding ( name, title, p, quote )
import qualified Text.XHtml as XHtml
import GHC ( SrcSpan(..), srcSpanStartLine, Name )
-import Module ( Module )
+import Module ( Module, ModuleName, moduleName, moduleNameString )
import Name ( getOccString, nameOccName, isValOcc )
+-- | Replace placeholder string elements with provided values.
+--
+-- Used to generate URL for customized external paths, usually provided with
+-- @--source-module@, @--source-entity@ and related command-line arguments.
+--
+-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
+-- "output/Foo.hs#foo"
spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
+
+
+-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'.
+spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
+ Maybe SrcSpan -> String -> String
+spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
where
file = fromMaybe "" maybe_file
mdl = case maybe_mod of
Nothing -> ""
- Just m -> moduleString m
+ Just m -> moduleNameString m
(name, kind) =
case maybe_name of
@@ -138,6 +150,11 @@ quote :: Html -> Html
quote h = char '`' +++ h +++ '`'
+-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@).
+promoQuote :: Html -> Html
+promoQuote h = char '\'' +++ h
+
+
parens, brackets, pabrackets, braces :: Html -> Html
parens h = char '(' +++ h +++ char ')'
brackets h = char '[' +++ h +++ char ']'
@@ -203,7 +220,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ]
collapseToggle :: String -> [HtmlAttr]
collapseToggle id_ = [ strAttr "onclick" js ]
where js = "toggleSection('" ++ id_ ++ "')";
-
+
-- | Attributes for an area that toggles a collapsed area,
-- and displays a control.
collapseControl :: String -> Bool -> String -> [HtmlAttr]
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2e28b0dd..bc293731 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,16 +22,13 @@ import Class
import CoAxiom
import ConLike
import Data.Either (lefts, rights)
-import Data.List( partition )
-import Data.Monoid (mempty)
import DataCon
import FamInstEnv
-import Haddock.Types
import HsSyn
import Name
import RdrName ( mkVarUnqual )
import PatSyn
-import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
+import SrcLoc ( Located, noLoc, unLoc )
import TcType ( tcSplitSigmaTy )
import TyCon
import Type
@@ -43,6 +40,9 @@ import Unique ( getUnique )
import Util ( filterByList, filterOut )
import Var
+import Haddock.Types
+import Haddock.Interface.Specialize
+
-- the main function here! yay!
@@ -99,7 +99,8 @@ tyThingToLHsDecl t = case t of
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps))
+ allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
+ (patSynType ps))
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -416,23 +417,38 @@ synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) =
- ( getName cls
- , map (unLoc . synifyType WithinType) ks
- , map (unLoc . synifyType WithinType) ts
- , ClassInst $ map (unLoc . synifyType WithinType) preds
- )
- where (ks,ts) = partitionInvisibles (classTyCon cls) id types
+synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
+ { ihdClsName = getName cls
+ , ihdKinds = map (unLoc . synifyType WithinType) ks
+ , ihdTypes = map (unLoc . synifyType WithinType) ts
+ , ihdInstType = ClassInst
+ { clsiCtx = map (unLoc . synifyType WithinType) preds
+ , clsiTyVars = synifyTyVars $ classTyVars cls
+ , clsiSigs = map synifyClsIdSig $ classMethods cls
+ , clsiAssocTys = do
+ (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
+ pure $ mkPseudoFamilyDecl fam
+ }
+ }
+ where
+ (ks,ts) = partitionInvisibles (classTyCon cls) id types
+ synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
-synifyFamInst fi opaque =
- let fff = case fi_flavor fi of
- SynFamilyInst | opaque -> return $ TypeInst Nothing
- SynFamilyInst ->
- return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
- DataFamilyInst c ->
- synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst
- in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,
- map (unLoc . synifyType WithinType) ts , f')
- where (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
+synifyFamInst fi opaque = do
+ ityp' <- ityp $ fi_flavor fi
+ return InstHead
+ { ihdClsName = fi_fam fi
+ , ihdKinds = synifyTypes ks
+ , ihdTypes = synifyTypes ts
+ , ihdInstType = ityp'
+ }
+ where
+ ityp SynFamilyInst | opaque = return $ TypeInst Nothing
+ ityp SynFamilyInst =
+ return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+ ityp (DataFamilyInst c) =
+ DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
+ (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
+ synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 2fbc5f82..4e5e008b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -16,7 +16,6 @@
module Haddock.GhcUtils where
-import Control.Applicative ( (<$>) )
import Control.Arrow
import Data.Function
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 86a9957c..faf043aa 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -33,14 +33,13 @@ import FamInstEnv
import FastString
import GHC
import GhcMonad (withSession)
-import Id
import InstEnv
import MonadUtils (liftIO)
import Name
import Outputable (text, sep, (<+>))
import PrelNames
+import SrcLoc
import TcRnDriver (tcRnGetInfo)
-import TcType (tcSplitSigmaTy)
import TyCon
import TyCoRep
import TysPrim( funTyCon )
@@ -69,25 +68,26 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
-> Ghc (ExportItem Name)
attachToExportItem expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+ e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
mb_info <- getAllInfo (tcdName d)
insts <- case mb_info of
Just (_, _, cls_instances, fam_instances) ->
- let fam_insts = [ (synifyFamInst i opaque, n)
+ let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )
| i <- sortBy (comparing instFam) fam_instances
- , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+ , let n = getName i
+ , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
]
- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
| 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) | (Right fi, n) <- fam_insts ]
- famInstErrs = [ errm | (Left errm, _) <- fam_insts ]
+ cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]
+ famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]
in do
dfs <- getDynFlags
let mkBug = (text "haddock-bug:" <+>) . text
@@ -106,6 +106,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
] }
attachFixities e = e
+ -- spanName: attach the location to the name that is the same file as the instance location
+ spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
+ let s1 = getSrcSpan s
+ sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
+ then instn
+ else clsn
+ in L (getSrcSpan s) sn
+ -- spanName on Either
+ spanNameE s (Left e) _ = L (getSrcSpan s) (Left e)
+ spanNameE s (Right ok) linst =
+ let L l r = spanName s ok linst
+ in L l (Right r)
instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 7da965ac..c41946f5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,9 @@ import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Types
+import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
+import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
import qualified Data.Map as M
import Data.Map (Map)
@@ -124,6 +127,8 @@ createInterface tm flags modMap instIfaceMap = do
mkAliasMap dflags $ tm_renamed_source tm
modWarn = moduleWarning dflags gre warnings
+ tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+
return $! Interface {
ifaceMod = mdl
, ifaceOrigFilename = msHsFilePath ms
@@ -147,6 +152,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceFamInstances = fam_instances
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
+ , ifaceTokenizedSrc = tokenizedSrc
}
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -519,7 +525,7 @@ mkExportItems
case findDecl t of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
+ export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -622,13 +628,19 @@ hiDecl dflags t = do
O.text "-- Please report this on Haddock issue tracker!"
bugWarn = O.showSDoc dflags . warnLine
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc splice fixity = do
+-- | This function is called for top-level bindings without type signatures.
+-- It gets the type signature from GHC and that means it's not going to
+-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
+-- declaration and use it instead - 'nLoc' here.
+hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+ -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl decl doc [] [] fixities splice)
+ Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)
where
+ fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
fixities = case fixity of
Just f -> [(name, f)]
Nothing -> []
@@ -739,7 +751,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
+ fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap)
| otherwise = return Nothing
mkExportItem decl@(L l (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
@@ -842,6 +854,30 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
+mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+ -> ErrMsgGhc (Maybe [RichToken])
+mkMaybeTokenizedSrc flags tm
+ | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
+ Just src -> do
+ tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+ return $ Just tokens
+ Nothing -> do
+ liftErrMsg . tell . pure $ concat
+ [ "Warning: Cannot hyperlink module \""
+ , moduleNameString . ms_mod_name $ summary
+ , "\" because renamed source is not available"
+ ]
+ return Nothing
+ | otherwise = return Nothing
+ where
+ summary = pm_mod_summary . tm_parsed_module $ tm
+
+mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
+mkTokenizedSrc ms src =
+ Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc
+ where
+ rawSrc = readFile $ msHsFilePath ms
+
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 9c46c700..3c14498c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -18,7 +18,6 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import Control.Applicative
import Data.IntSet (toList)
import Data.List
import Documentation.Haddock.Doc (metaDocConcat)
@@ -30,9 +29,9 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import Name
-import RdrHsSyn ( setRdrNameSpace )
import Outputable ( showPpr )
import RdrName
+import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-> Maybe (MDoc Name)
@@ -76,7 +75,13 @@ processModuleHeader dflags gre safety mayStr = do
where
failure = (emptyHaddockModInfo, Nothing)
-
+-- | 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
+-- trying to convert 'RdrName's to 'Name's, with some guesswork and
+-- fallbacks in case we can't locate the identifiers.
+--
+-- See the comments in the source for implementation commentary.
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
where
@@ -84,19 +89,36 @@ rename dflags gre = rn
DocAppend a b -> DocAppend (rn a) (rn b)
DocParagraph doc -> DocParagraph (rn doc)
DocIdentifier x -> do
- let choices = dataTcOccs' x
+ -- Generate the choices for the possible kind of thing this
+ -- is.
+ let choices = dataTcOccs x
+ -- Try to look up all the names in the GlobalRdrEnv that match
+ -- the names.
let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+
case names of
+ -- We found no names in the env so we start guessing.
[] ->
case choices of
[] -> DocMonospaced (DocString (showPpr dflags x))
- [a] -> outOfScope dflags a
- a:b:_ | isRdrTc a -> outOfScope dflags a
- | otherwise -> outOfScope dflags b
+ -- There was nothing in the environment so we need to
+ -- pick some default from what's available to us. We
+ -- diverge here from the old way where we would default
+ -- to type constructors as we're much more likely to
+ -- actually want anchors to regular definitions than
+ -- type constructor names (such as in #253). So now we
+ -- only get type constructor links if they are actually
+ -- in scope.
+ a:_ -> outOfScope dflags a
+
+ -- There is only one name in the environment that matches so
+ -- use it.
[a] -> DocIdentifier a
- a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
- -- If an id can refer to multiple things, we give precedence to type
- -- constructors.
+ -- But when there are multiple names available, default to
+ -- type constructors: somewhat awfully GHC returns the
+ -- values in the list positionally.
+ a:b:_ | isTyConName a -> DocIdentifier a
+ | otherwise -> DocIdentifier b
DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
@@ -117,21 +139,14 @@ rename dflags gre = rn
DocString str -> DocString str
DocHeader (Header l t) -> DocHeader $ Header l (rn t)
-dataTcOccs' :: RdrName -> [RdrName]
--- If the input is a data constructor, return both it and a type
--- constructor. This is useful when we aren't sure which we are
--- looking at.
---
--- We use this definition instead of the GHC's to provide proper linking to
--- functions accross modules. See ticket #253 on Haddock Trac.
-dataTcOccs' rdr_name
- | isDataOcc occ = [rdr_name, rdr_name_tc]
- | otherwise = [rdr_name]
- where
- occ = rdrNameOcc rdr_name
- rdr_name_tc = setRdrNameSpace rdr_name tcName
-
-
+-- | Wrap an identifier that's out of scope (i.e. wasn't found in
+-- '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
+-- users shouldn't rely on this doing the right thing. See tickets
+-- #253 and #375 on the confusion this causes depending on which
+-- default we pick in 'rename'.
outOfScope :: DynFlags -> RdrName -> Doc a
outOfScope dflags x =
case x of
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index d92e8b2a..e7d2a085 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -11,7 +11,6 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Data.Char
import DynFlags
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 091d9bff..2478ce23 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -12,7 +13,7 @@
module Haddock.Interface.Rename (renameInterface) where
-import Data.Traversable (traverse, Traversable)
+import Data.Traversable (mapM)
import Haddock.GhcUtils
import Haddock.Types
@@ -25,7 +26,6 @@ import Control.Applicative
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
-import Data.Traversable (mapM)
import Prelude hiding (mapM)
@@ -287,16 +287,24 @@ renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename na
renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (className, k, types, rest) = do
- className' <- rename className
- k' <- mapM renameType k
- types' <- mapM renameType types
- rest' <- case rest of
- ClassInst cs -> ClassInst <$> mapM renameType cs
+renameInstHead InstHead {..} = do
+ cname <- rename ihdClsName
+ kinds <- mapM renameType ihdKinds
+ types <- mapM renameType ihdTypes
+ itype <- case ihdInstType of
+ ClassInst { .. } -> ClassInst
+ <$> mapM renameType clsiCtx
+ <*> renameLHsQTyVars clsiTyVars
+ <*> mapM renameSig clsiSigs
+ <*> mapM renamePseudoFamilyDecl clsiAssocTys
TypeInst ts -> TypeInst <$> traverse renameType ts
DataInst dd -> DataInst <$> renameTyClD dd
- return (className', k', types', rest')
-
+ return InstHead
+ { ihdClsName = cname
+ , ihdKinds = kinds
+ , ihdTypes = types
+ , ihdInstType = itype
+ }
renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
@@ -375,6 +383,16 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdTyVars = ltyvars', fdResultSig = result'
, fdInjectivityAnn = injectivity' })
+
+renamePseudoFamilyDecl :: PseudoFamilyDecl Name
+ -> RnM (PseudoFamilyDecl DocName)
+renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
+ <$> renameFamilyInfo pfdInfo
+ <*> renameL pfdLName
+ <*> mapM renameLType pfdTyVars
+ <*> renameFamilyResultSig pfdKindSig
+
+
renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
@@ -553,10 +571,11 @@ renameExportItem item = case item of
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
- instances' <- forM instances $ \(inst, idoc) -> do
+ instances' <- forM instances $ \(inst, idoc, L l n) -> do
inst' <- renameInstHead inst
+ n' <- rename n
idoc' <- mapM renameDoc idoc
- return (inst', idoc')
+ return (inst', idoc',L l n')
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
new file mode 100644
index 00000000..ab719fe8
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -0,0 +1,406 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Haddock.Interface.Specialize
+ ( specializeInstHead
+ ) where
+
+
+import Haddock.Syb
+import Haddock.Types
+
+import GHC
+import Name
+import FastString
+
+import Control.Monad
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+
+import Data.Data
+import qualified Data.List as List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+-- | Instantiate all occurrences of given name with particular type.
+specialize :: (Eq name, Typeable name)
+ => Data a
+ => name -> HsType name -> a -> a
+specialize name details =
+ everywhere $ mkT step
+ where
+ step (HsTyVar (L _ name')) | name == name' = details
+ step typ = typ
+
+
+-- | Instantiate all occurrences of given names with corresponding types.
+--
+-- It is just a convenience function wrapping 'specialize' that supports more
+-- that one specialization.
+specialize' :: (Eq name, Typeable name)
+ => Data a
+ => [(name, HsType name)] -> a -> a
+specialize' = flip $ foldr (uncurry specialize)
+
+
+-- | Instantiate given binders with corresponding types.
+--
+-- Again, it is just a convenience function around 'specialize'. Note that
+-- length of type list should be the same as the number of binders.
+specializeTyVarBndrs :: (Eq name, DataId name)
+ => Data a
+ => LHsQTyVars name -> [HsType name]
+ -> a -> a
+specializeTyVarBndrs bndrs typs =
+ specialize' $ zip bndrs' typs
+ where
+ bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
+ bname (UserTyVar (L _ name)) = name
+ bname (KindedTyVar (L _ name) _) = name
+
+
+specializePseudoFamilyDecl :: (Eq name, DataId name)
+ => LHsQTyVars name -> [HsType name]
+ -> PseudoFamilyDecl name
+ -> PseudoFamilyDecl name
+specializePseudoFamilyDecl bndrs typs decl =
+ decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
+ where
+ specializeTyVars = specializeTyVarBndrs bndrs typs
+
+
+specializeSig :: forall name . (Eq name, DataId name, SetName name)
+ => LHsQTyVars name -> [HsType name]
+ -> Sig name
+ -> Sig name
+specializeSig bndrs typs (TypeSig lnames typ) =
+ TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
+ where
+ true_type :: HsType name
+ true_type = unLoc (hswc_body (hsib_body typ))
+ typ' :: HsType name
+ typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
+ fv = foldr Set.union Set.empty . map freeVariables $ typs
+specializeSig _ _ sig = sig
+
+
+-- | Make all details of instance head (signatures, associated types)
+-- specialized to that particular instance type.
+specializeInstHead :: (Eq name, DataId name, SetName name)
+ => InstHead name -> InstHead name
+specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
+ ihd { ihdInstType = instType' }
+ where
+ instType' = clsi
+ { clsiSigs = map specializeSig' clsiSigs
+ , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys
+ }
+ specializeSig' = specializeSig clsiTyVars ihdTypes
+ specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes
+specializeInstHead ihd = ihd
+
+
+-- | Make given type use tuple and list literals where appropriate.
+--
+-- After applying 'specialize' function some terms may not use idiomatic list
+-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
+-- can be fixed using 'sugar' function, that will turn such types into @[a]@
+-- and @(a, b, c)@.
+sugar :: forall name. (NamedThing name, DataId name)
+ => HsType name -> HsType name
+sugar =
+ everywhere $ mkT step
+ where
+ step :: HsType name -> HsType name
+ step = sugarOperators . sugarTuples . sugarLists
+
+
+sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+ where
+ name' = getName name
+ strName = occNameString . nameOccName $ name'
+sugarLists typ = typ
+
+
+sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples typ =
+ aux [] typ
+ where
+ aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+ aux apps (HsParTy (L _ typ')) = aux apps typ'
+ aux apps (HsTyVar (L _ name))
+ | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+ where
+ name' = getName name
+ strName = occNameString . nameOccName $ name'
+ suitable = case parseTupleArity strName of
+ Just arity -> arity == length apps
+ Nothing -> False
+ aux _ _ = typ
+
+
+sugarOperators :: NamedThing name => HsType name -> HsType name
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
+ | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
+ where
+ name' = getName name
+sugarOperators typ = typ
+
+
+-- | Compute arity of given tuple operator.
+--
+-- >>> parseTupleArity "(,,)"
+-- Just 3
+--
+-- >>> parseTupleArity "(,,,,)"
+-- Just 5
+--
+-- >>> parseTupleArity "abc"
+-- Nothing
+--
+-- >>> parseTupleArity "()"
+-- Nothing
+parseTupleArity :: String -> Maybe Int
+parseTupleArity ('(':commas) = do
+ n <- parseCommas commas
+ guard $ n /= 0
+ return $ n + 1
+ where
+ parseCommas (',':rest) = (+ 1) <$> parseCommas rest
+ parseCommas ")" = Just 0
+ parseCommas _ = Nothing
+parseTupleArity _ = Nothing
+
+
+-- | Haskell AST type representation.
+--
+-- This type is used for renaming (more below), essentially the ambiguous (!)
+-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
+-- it was 'OccName' before, but turned out that 'OccName' sometimes also
+-- contains namespace information, differentiating visually same types.
+--
+-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
+-- not converted to 'String' or alike to avoid new allocations. Additionally,
+-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
+-- quite nice.
+type NameRep = FastString
+
+getNameRep :: NamedThing name => name -> NameRep
+getNameRep = occNameFS . getOccName
+
+nameRepString :: NameRep -> String
+nameRepString = unpackFS
+
+stringNameRep :: String -> NameRep
+stringNameRep = mkFastString
+
+setInternalNameRep :: SetName name => NameRep -> name -> name
+setInternalNameRep = setInternalOccName . mkVarOccFS
+
+setInternalOccName :: SetName name => OccName -> name -> name
+setInternalOccName occ name =
+ setName nname' name
+ where
+ nname = getName name
+ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
+
+
+-- | Compute set of free variables of given type.
+freeVariables :: forall name. (NamedThing name, DataId name)
+ => HsType name -> Set NameRep
+freeVariables =
+ everythingWithState Set.empty Set.union query
+ where
+ query term ctx = case cast term :: Maybe (HsType name) of
+ Just (HsForAllTy bndrs _) ->
+ (Set.empty, Set.union ctx (bndrsNames bndrs))
+ Just (HsTyVar (L _ name))
+ | getName name `Set.member` ctx -> (Set.empty, ctx)
+ | otherwise -> (Set.singleton $ getNameRep name, ctx)
+ _ -> (Set.empty, ctx)
+ bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+
+
+-- | Make given type visually unambiguous.
+--
+-- After applying 'specialize' method, some free type variables may become
+-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
+-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
+-- different type variable than latter one. Applying 'rename' function
+-- will fix that type to be visually unambiguous again (making it something
+-- like @(a -> c) -> b@).
+rename :: SetName name => Set NameRep -> HsType name -> HsType name
+rename fv typ = runReader (renameType typ) $ RenameEnv
+ { rneFV = fv
+ , rneCtx = Map.empty
+ }
+
+
+-- | Renaming monad.
+type Rename name = Reader (RenameEnv name)
+
+-- | Binding generation monad.
+type Rebind name = State (RenameEnv name)
+
+data RenameEnv name = RenameEnv
+ { rneFV :: Set NameRep
+ , rneCtx :: Map Name name
+ }
+
+
+renameType :: SetName name => HsType name -> Rename name (HsType name)
+renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
+ HsForAllTy
+ <$> pure bndrs'
+ <*> renameLType lt
+renameType (HsQualTy lctxt lt) =
+ HsQualTy
+ <$> located renameContext lctxt
+ <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> located renameName name
+renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
+renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
+renameType (HsListTy lt) = HsListTy <$> renameLType lt
+renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
+renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsOpTy la lop lb) =
+ HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
+renameType (HsParTy lt) = HsParTy <$> renameLType lt
+renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
+renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
+renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType t@(HsSpliceTy _ _) = pure t
+renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
+renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
+renameType t@(HsRecTy _) = pure t
+renameType t@(HsCoreTy _) = pure t
+renameType (HsExplicitListTy ph ltys) =
+ HsExplicitListTy ph <$> renameLTypes ltys
+renameType (HsExplicitTupleTy phs ltys) =
+ HsExplicitTupleTy phs <$> renameLTypes ltys
+renameType t@(HsTyLit _) = pure t
+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
+renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
+
+
+renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
+renameLType = located renameType
+
+
+renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes = mapM renameLType
+
+
+renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
+renameContext = renameLTypes
+
+{-
+renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+-}
+
+
+renameName :: SetName name => name -> Rename name name
+renameName name = do
+ RenameEnv { rneCtx = ctx } <- ask
+ pure $ fromMaybe name (Map.lookup (getName name) ctx)
+
+
+rebind :: SetName name
+ => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)
+ -> Rename name a
+rebind lbndrs action = do
+ (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
+ local (const env') (action lbndrs')
+
+
+rebindLTyVarBndrs :: SetName name
+ => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
+rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
+
+
+rebindTyVarBndr :: SetName name
+ => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
+rebindTyVarBndr (UserTyVar (L l name)) =
+ UserTyVar . L l <$> rebindName name
+rebindTyVarBndr (KindedTyVar name kinds) =
+ KindedTyVar <$> located rebindName name <*> pure kinds
+
+
+rebindName :: SetName name => name -> Rebind name name
+rebindName name = do
+ RenameEnv { .. } <- get
+ taken <- takenNames
+ case Map.lookup (getName name) rneCtx of
+ Just name' -> pure name'
+ Nothing | getNameRep name `Set.member` taken -> freshName name
+ Nothing -> reuseName name
+
+
+-- | Generate fresh occurrence name, put it into context and return.
+freshName :: SetName name => name -> Rebind name name
+freshName name = do
+ env@RenameEnv { .. } <- get
+ taken <- takenNames
+ let name' = setInternalNameRep (findFreshName taken rep) name
+ put $ env { rneCtx = Map.insert nname name' rneCtx }
+ return name'
+ where
+ nname = getName name
+ rep = getNameRep nname
+
+
+reuseName :: SetName name => name -> Rebind name name
+reuseName name = do
+ env@RenameEnv { .. } <- get
+ put $ env { rneCtx = Map.insert (getName name) name rneCtx }
+ return name
+
+
+takenNames :: NamedThing name => Rebind name (Set NameRep)
+takenNames = do
+ RenameEnv { .. } <- get
+ return $ Set.union rneFV (ctxElems rneCtx)
+ where
+ ctxElems = Set.fromList . map getNameRep . Map.elems
+
+
+findFreshName :: Set NameRep -> NameRep -> NameRep
+findFreshName taken =
+ fromJust . List.find isFresh . alternativeNames
+ where
+ isFresh = not . flip Set.member taken
+
+
+alternativeNames :: NameRep -> [NameRep]
+alternativeNames name
+ | [_] <- nameRepString name = letterNames ++ alternativeNames' name
+ where
+ letterNames = map (stringNameRep . pure) ['a'..'z']
+alternativeNames name = alternativeNames' name
+
+
+alternativeNames' :: NameRep -> [NameRep]
+alternativeNames' name =
+ [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
+ where
+ str = nameRepString name
+
+
+located :: Functor f => (a -> f b) -> Located a -> f (Located b)
+located f (L loc e) = L loc <$> f e
+
+
+tyVarName :: HsTyVarBndr name -> name
+tyVarName (UserTyVar name) = unLoc name
+tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4b66348c..73185092 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
- InterfaceFile(..), ifUnitId,
+ InterfaceFile(..), ifUnitId, ifModule,
readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where
@@ -25,7 +25,6 @@ import Haddock.Utils hiding (out)
import Control.Monad
import Data.Array
-import Data.Functor ((<$>))
import Data.IORef
import Data.List
import qualified Data.Map as Map
@@ -52,6 +51,12 @@ data InterfaceFile = InterfaceFile {
}
+ifModule :: InterfaceFile -> Module
+ifModule if_ =
+ case ifInstalledIfaces if_ of
+ [] -> error "empty InterfaceFile"
+ iface:_ -> instMod iface
+
ifUnitId :: InterfaceFile -> UnitId
ifUnitId if_ =
case ifInstalledIfaces if_ of
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index e847333e..f84989ef 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -21,6 +21,7 @@ module Haddock.Options (
optContentsUrl,
optIndexUrl,
optCssFile,
+ optSourceCssFile,
sourceUrls,
wikiUrls,
optDumpInterfaceFile,
@@ -66,6 +67,8 @@ data Flag
| Flag_WikiEntityURL String
| Flag_LaTeX
| Flag_LaTeXStyle String
+ | Flag_HyperlinkedSource
+ | Flag_SourceCss String
| Flag_Help
| Flag_Verbosity String
| Flag_Version
@@ -116,6 +119,10 @@ options backwardsCompat =
Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
Option [] ["hoogle"] (NoArg Flag_Hoogle)
"output for Hoogle; you may want --package-name and --package-version too",
+ Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
+ "generate highlighted and hyperlinked source code (for use with --html)",
+ Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
+ "use custom CSS file instead of default one in hyperlinked source",
Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")
"URL for a source code link on the contents\nand index pages",
Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
@@ -239,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
optCssFile :: [Flag] -> Maybe FilePath
optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+optSourceCssFile :: [Flag] -> Maybe FilePath
+optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ]
sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
sourceUrls flags =
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
new file mode 100644
index 00000000..4847e486
--- /dev/null
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE Rank2Types #-}
+
+
+module Haddock.Syb
+ ( everything, everythingWithState, everywhere
+ , mkT
+ , combine
+ ) where
+
+
+import Data.Data
+import Control.Applicative
+
+
+-- | Perform a query on each level of a tree.
+--
+-- This is stolen directly from SYB package and copied here to not introduce
+-- additional dependencies.
+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+ -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+
+-- | Perform a query with state on each level of a tree.
+--
+-- This is the same as 'everything' but allows for stateful computations. In
+-- SYB it is called @everythingWithContext@ but I find this name somewhat
+-- nicer.
+everythingWithState :: s -> (r -> r -> r)
+ -> (forall a. Data a => a -> s -> (r, s))
+ -> (forall a. Data a => a -> r)
+everythingWithState s k f x =
+ let (r, s') = f x s
+ in foldl k r (gmapQ (everythingWithState s' k f) x)
+
+
+-- | Apply transformation on each level of a tree.
+--
+-- Just like 'everything', this is stolen from SYB package.
+everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
+everywhere f = f . gmapT (everywhere f)
+
+-- | Create generic transformation.
+--
+-- Another function stolen from SYB package.
+mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
+mkT f = case cast f of
+ Just f' -> f'
+ Nothing -> id
+
+-- | Combine two queries into one using alternative combinator.
+combine :: Alternative f => (forall a. Data a => a -> f r)
+ -> (forall a. Data a => a -> f r)
+ -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6f9b64dd..b837970b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -27,19 +27,23 @@ import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Data.Typeable
import Data.Map (Map)
+import Data.Data (Data)
import qualified Data.Map as Map
import Documentation.Haddock.Types
import BasicTypes (Fixity(..))
+
import GHC hiding (NoLink)
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
+import Coercion
+import NameSet
import OccName
import Outputable
-import NameSet (NameSet)
-import Coercion (Coercion)
import Control.Applicative (Applicative(..))
import Control.Monad (ap)
+import Haddock.Backends.Hyperlinker.Types
+
-----------------------------------------------------------------------------
-- * Convenient synonyms
-----------------------------------------------------------------------------
@@ -53,7 +57,6 @@ type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type InstMap = Map SrcSpan Name
type FixMap = Map Name Fixity
-type SrcMap = Map UnitId FilePath
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -129,6 +132,10 @@ data Interface = Interface
-- | Warnings for things defined in this module.
, ifaceWarningMap :: !WarningMap
+
+ -- | Tokenized source code of module (avaliable if Haddock is invoked with
+ -- source generation flag).
+ , ifaceTokenizedSrc :: !(Maybe [RichToken])
}
type WarningMap = Map Name (Doc Name)
@@ -270,7 +277,6 @@ unrenameDocForDecl (doc, fnArgsDoc) =
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
-
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
@@ -280,7 +286,16 @@ data DocName
| Undocumented Name
-- ^ This thing is not part of the (existing or resulting)
-- documentation, as far as Haddock knows.
- deriving Eq
+ deriving (Eq, Data)
+
+type instance PostRn DocName NameSet = PlaceHolder
+type instance PostRn DocName Fixity = PlaceHolder
+type instance PostRn DocName Bool = PlaceHolder
+type instance PostRn DocName [Name] = PlaceHolder
+
+type instance PostTc DocName Kind = PlaceHolder
+type instance PostTc DocName Type = PlaceHolder
+type instance PostTc DocName Coercion = PlaceHolder
instance NamedThing DocName where
getName (Documented name _) = name
@@ -295,27 +310,106 @@ instance OutputableBndr DocName where
pprPrefixOcc = pprPrefixOcc . getName
pprInfixOcc = pprInfixOcc . getName
+class NamedThing name => SetName name where
+
+ setName :: Name -> name -> name
+
+
+instance SetName Name where
+
+ setName name' _ = name'
+
+
+instance SetName DocName where
+
+ setName name' (Documented _ mdl) = Documented name' mdl
+ setName name' (Undocumented _) = Undocumented name'
+
+
+
-----------------------------------------------------------------------------
-- * Instances
-----------------------------------------------------------------------------
-- | The three types of instances
data InstType name
- = ClassInst [HsType name] -- ^ Context
+ = ClassInst
+ { clsiCtx :: [HsType name]
+ , clsiTyVars :: LHsQTyVars name
+ , clsiSigs :: [Sig name]
+ , clsiAssocTys :: [PseudoFamilyDecl name]
+ }
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
instance OutputableBndr a => Outputable (InstType a) where
- ppr (ClassInst a) = text "ClassInst" <+> ppr a
+ ppr (ClassInst { .. }) = text "ClassInst"
+ <+> ppr clsiCtx
+ <+> ppr clsiTyVars
+ <+> ppr clsiSigs
ppr (TypeInst a) = text "TypeInst" <+> ppr a
ppr (DataInst a) = text "DataInst" <+> ppr a
--- | An instance head that may have documentation.
-type DocInstance name = (InstHead name, Maybe (MDoc name))
+
+-- | Almost the same as 'FamilyDecl' except for type binders.
+--
+-- In order to perform type specialization for class instances, we need to
+-- substitute class variables to appropriate type. However, type variables in
+-- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'.
+-- This makes type substitution impossible and to overcome this issue,
+-- 'PseudoFamilyDecl' type is introduced.
+data PseudoFamilyDecl name = PseudoFamilyDecl
+ { pfdInfo :: FamilyInfo name
+ , pfdLName :: Located name
+ , pfdTyVars :: [LHsType name]
+ , pfdKindSig :: LFamilyResultSig name
+ }
+
+
+mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
+mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
+ { pfdInfo = fdInfo
+ , pfdLName = fdLName
+ , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
+ , pfdKindSig = fdResultSig
+ }
+ where
+ mkType (KindedTyVar (L loc name) lkind) =
+ HsKindSig tvar lkind
+ where
+ tvar = L loc (HsTyVar (L loc name))
+ mkType (UserTyVar name) = HsTyVar name
+
+
+-- | An instance head that may have documentation and a source location.
+type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
-- | The head of an instance. Consists of a class name, a list of kind
-- parameters, a list of type parameters and an instance type
-type InstHead name = (name, [HsType name], [HsType name], InstType name)
+data InstHead name = InstHead
+ { ihdClsName :: name
+ , ihdKinds :: [HsType name]
+ , ihdTypes :: [HsType name]
+ , ihdInstType :: InstType name
+ }
+
+
+-- | An instance origin information.
+--
+-- This is used primarily in HTML backend to generate unique instance
+-- identifiers (for expandable sections).
+data InstOrigin name
+ = OriginClass name
+ | OriginData name
+ | OriginFamily name
+
+
+instance NamedThing name => NamedThing (InstOrigin name) where
+
+ getName (OriginClass name) = getName name
+ getName (OriginData name) = getName name
+ getName (OriginFamily name) = getName name
+
-----------------------------------------------------------------------------
-- * Documentation comments
diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs
index 2ef3a257..4e9a581a 100644
--- a/haddock-api/src/Haddock/Version.hs
+++ b/haddock-api/src/Haddock/Version.hs
@@ -9,7 +9,7 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
-module Haddock.Version (
+module Haddock.Version (
projectName, projectVersion, projectUrl
) where
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
new file mode 100644
index 00000000..8cd2690e
--- /dev/null
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -0,0 +1,98 @@
+module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where
+
+
+import Test.Hspec
+import Test.QuickCheck
+
+import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Types
+
+
+main :: IO ()
+main = hspec spec
+
+
+spec :: Spec
+spec = do
+ describe "parse" parseSpec
+
+
+parseSpec :: Spec
+parseSpec = do
+
+ it "is total" $
+ property $ \src -> length (parse src) `shouldSatisfy` (>= 0)
+
+ it "retains file layout" $
+ property $ \src -> concatMap tkValue (parse src) == src
+
+ context "when parsing single-line comments" $ do
+
+ it "should ignore content until the end of line" $
+ "-- some very simple comment\nidentifier"
+ `shouldParseTo`
+ [TkComment, TkSpace, TkIdentifier]
+
+ it "should allow endline escaping" $
+ "-- first line\\\nsecond line\\\nand another one"
+ `shouldParseTo`
+ [TkComment]
+
+ context "when parsing multi-line comments" $ do
+
+ it "should support nested comments" $
+ "{- comment {- nested -} still comment -} {- next comment -}"
+ `shouldParseTo`
+ [TkComment, TkSpace, TkComment]
+
+ it "should distinguish compiler pragma" $
+ "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
+ `shouldParseTo`
+ [TkComment, TkPragma, TkComment]
+
+ it "should recognize preprocessor directives" $ do
+ "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]
+ "x # y" `shouldParseTo`
+ [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
+
+ it "should distinguish basic language constructs" $ do
+ "(* 2) <$> (\"abc\", foo)" `shouldParseTo`
+ [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial
+ , TkSpace, TkOperator, TkSpace
+ , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
+ ]
+ "let foo' = foo in foo' + foo'" `shouldParseTo`
+ [ TkKeyword, TkSpace, TkIdentifier
+ , TkSpace, TkGlyph, TkSpace
+ , TkIdentifier, TkSpace, TkKeyword, TkSpace
+ , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
+ ]
+ "square x = y^2 where y = x" `shouldParseTo`
+ [ TkIdentifier, TkSpace, TkIdentifier
+ , TkSpace, TkGlyph, TkSpace
+ , TkIdentifier, TkOperator, TkNumber
+ , TkSpace, TkKeyword, TkSpace
+ , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
+ ]
+
+ it "should parse do-notation syntax" $ do
+ "do { foo <- getLine; putStrLn foo }" `shouldParseTo`
+ [ TkKeyword, TkSpace, TkSpecial, TkSpace
+ , TkIdentifier, TkSpace, TkGlyph, TkSpace
+ , TkIdentifier, TkSpecial, TkSpace
+ , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
+ ]
+
+ unlines
+ [ "do"
+ , " foo <- getLine"
+ , " putStrLn foo"
+ ] `shouldParseTo`
+ [ TkKeyword, TkSpace, TkIdentifier
+ , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace
+ , TkIdentifier, TkSpace, TkIdentifier, TkSpace
+ ]
+
+
+shouldParseTo :: String -> [TokenType] -> Expectation
+str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens
diff --git a/haddock-api/test/Spec.hs b/haddock-api/test/Spec.hs
new file mode 100644
index 00000000..a824f8c3
--- /dev/null
+++ b/haddock-api/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}