aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs5
-rw-r--r--src/Haddock/Interface/Create.hs18
-rw-r--r--src/Haddock/Lex.x3
-rw-r--r--tests/html-tests/tests/IgnoreExports.hs10
-rw-r--r--tests/html-tests/tests/IgnoreExports.html.ref101
5 files changed, 124 insertions, 13 deletions
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 7c2375cf..274078a6 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -52,7 +52,10 @@ ppDocName qual docName =
case docName of
Documented name mdl ->
linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
- Undocumented name -> ppQualifyName qual name (nameModule name)
+ Undocumented name
+ | isExternalName name || isWiredInName name ->
+ ppQualifyName qual name (nameModule name)
+ | otherwise -> ppName name
-- | Render a name depending on the selected qualification mode
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index ed51734d..94575209 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -35,7 +35,7 @@ import HscTypes
import Name
import Bag
import RdrName
-import TcRnTypes (tcg_warns)
+import TcRnTypes
import FastString (unpackFS)
@@ -51,7 +51,8 @@ createInterface tm flags modMap instIfaceMap = do
dflags = ms_hspp_opts ms
instances = modInfoInstances mi
exportedNames = modInfoExports mi
- warnings = tcg_warns . fst . tm_internals_ $ tm
+
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -62,10 +63,6 @@ createInterface tm flags modMap instIfaceMap = do
return (emptyRnGroup, Nothing, Nothing)
Just (x, _, y, z) -> return (x, y, z)
- -- The pattern-match should not fail, because createInterface is only
- -- done on loaded modules.
- Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
-
opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
@@ -80,7 +77,7 @@ createInterface tm flags modMap instIfaceMap = do
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
(docMap0, argMap, subMap, declMap) <-
- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+ liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
let docMap = addWarnings warnings gre exportedNames docMap0
maps = (docMap, argMap, subMap, declMap)
@@ -206,10 +203,9 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Instance]
- -> [Name]
-> [(LHsDecl Name, [HsDocString])]
-> ErrMsgM Maps
-mkMaps dflags gre instances exports decls = do
+mkMaps dflags gre instances decls = do
(a, b, c, d) <- unzip4 <$> mapM mappings decls
return (f a, f b, f c, f d)
where
@@ -223,7 +219,7 @@ mkMaps dflags gre instances exports decls = do
m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
return (doc, m')
(doc, args) <- declDoc docStrs (typeDocs decl)
- let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ]
+ let subs = subordinates decl
(subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
let ns = names decl
subNs = [ n | (n, _, _) <- subs ]
@@ -238,7 +234,7 @@ mkMaps dflags gre instances exports decls = do
names :: HsDecl Name -> [Name]
names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2].
- names decl = filter (`elem` exports) (getMainDeclBinder decl)
+ names decl = getMainDeclBinder decl
-- Note [2]:
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index f65aee8c..b9ebe688 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -34,6 +34,7 @@ import Data.Char
import Data.Word (Word8)
import Numeric
import System.IO.Unsafe
+import Debug.Trace
}
$ws = $white # \n
@@ -181,7 +182,7 @@ tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para i
go inp@(pos, _, str) sc =
case alexScan inp sc of
AlexEOF -> []
- AlexError _ -> error "lexical error"
+ AlexError _ -> []
AlexSkip inp' _ -> go inp' sc
AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags
diff --git a/tests/html-tests/tests/IgnoreExports.hs b/tests/html-tests/tests/IgnoreExports.hs
new file mode 100644
index 00000000..0321ad02
--- /dev/null
+++ b/tests/html-tests/tests/IgnoreExports.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+module IgnoreExports (foo) where
+
+-- | documentation for foo
+foo :: Int
+foo = 23
+
+-- | documentation for bar
+bar :: Int
+bar = 23
diff --git a/tests/html-tests/tests/IgnoreExports.html.ref b/tests/html-tests/tests/IgnoreExports.html.ref
new file mode 100644
index 00000000..4c093035
--- /dev/null
+++ b/tests/html-tests/tests/IgnoreExports.html.ref
@@ -0,0 +1,101 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >IgnoreExports</title
+ ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+ /><script src="haddock-util.js" type="text/javascript"
+ ></script
+ ><script type="text/javascript"
+ >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_IgnoreExports.html");};
+//]]>
+</script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href=""
+ >Contents</a
+ ></li
+ ><li
+ ><a href=""
+ >Index</a
+ ></li
+ ></ul
+ ><p class="caption empty"
+ >&nbsp;</p
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >None</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >IgnoreExports</p
+ ></div
+ ><div id="synopsis"
+ ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+ >Synopsis</p
+ ><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+ ><li class="src short"
+ ><a href=""
+ >foo</a
+ > :: <a href=""
+ >Int</a
+ ></li
+ ><li class="src short"
+ ><a href=""
+ >bar</a
+ > :: <a href=""
+ >Int</a
+ ></li
+ ></ul
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:foo" class="def"
+ >foo</a
+ > :: <a href=""
+ >Int</a
+ ></p
+ ><div class="doc"
+ ><p
+ >documentation for foo
+</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:bar" class="def"
+ >bar</a
+ > :: <a href=""
+ >Int</a
+ ></p
+ ><div class="doc"
+ ><p
+ >documentation for bar
+</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ><p
+ >Produced by <a href=""
+ >Haddock</a
+ > version 2.10.0</p
+ ></div
+ ></body
+ ></html
+>
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 23:19:17 +0000