aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/DevHelp.hs2
-rw-r--r--src/Haddock/Backends/HH.hs2
-rw-r--r--src/Haddock/Backends/HH2.hs2
-rw-r--r--src/Haddock/Backends/Html.hs11
-rw-r--r--src/Haddock/Backends/Xhtml.hs7
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs2
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs30
-rw-r--r--src/Haddock/Backends/Xhtml/Util.hs14
-rw-r--r--src/Haddock/Utils.hs55
9 files changed, 76 insertions, 49 deletions
diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs
index 4028890d..e6225303 100644
--- a/src/Haddock/Backends/DevHelp.hs
+++ b/src/Haddock/Backends/DevHelp.hs
@@ -82,5 +82,5 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do
ppReference :: Name -> [Module] -> Doc
ppReference _ [] = empty
ppReference name (mdl:refs) =
- text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$
+ text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (moduleNameUrl mdl (nameOccName name))<>text"\"/>" $$
ppReference name refs
diff --git a/src/Haddock/Backends/HH.hs b/src/Haddock/Backends/HH.hs
index 39390573..7f58fd02 100644
--- a/src/Haddock/Backends/HH.hs
+++ b/src/Haddock/Backends/HH.hs
@@ -125,7 +125,7 @@ ppHHIndex odir maybe_package ifaces = do
ppReference name [] = empty
ppReference name (Module mdl:refs) =
- text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$
+ text "<PARAM name=\"Local\" value=\"" <> text (moduleNameURL mdl name) <> text "\">" $$
ppReference name refs
diff --git a/src/Haddock/Backends/HH2.hs b/src/Haddock/Backends/HH2.hs
index 7a49bded..b2fe5e92 100644
--- a/src/Haddock/Backends/HH2.hs
+++ b/src/Haddock/Backends/HH2.hs
@@ -114,7 +114,7 @@ ppHH2Index odir maybe_package ifaces = do
text "</Keyword>" $$
ppList vs
- ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"
+ ppJump name (Module mdl) = text "<Jump Url=\"" <> text (moduleNameUrl mdl name) <> text "\"/>"
-----------------------------------------------------------------------------------
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 09d9fc5e..013f6bc4 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -729,8 +729,7 @@ processForMiniSynopsis _ _ _ = noHtml
ppNameMini :: Module -> OccName -> Html
ppNameMini mdl nm =
- anchor ! [ href ( moduleHtmlFile mdl ++ "#"
- ++ (escapeStr (anchorNameStr nm)))
+ anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
<< ppBinder' nm
@@ -1669,7 +1668,7 @@ ppDocName (Documented name mdl) =
ppDocName (Undocumented name) = toHtml (getOccString name)
linkTarget :: OccName -> Html
-linkTarget n = namedAnchor (anchorNameStr n) << toHtml ""
+linkTarget n = namedAnchor (nameAnchorId n) << toHtml ""
ppName :: Name -> Html
ppName name = toHtml (getOccString name)
@@ -1678,7 +1677,7 @@ ppName name = toHtml (getOccString name)
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 (anchorNameStr n) << ppBinder' n
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
ppBinder False n = linkTarget n +++ bold << ppBinder' n
@@ -1696,8 +1695,8 @@ linkIdOcc :: Module -> Maybe OccName -> Html -> Html
linkIdOcc mdl mbName = anchor ! [href uri]
where
uri = case mbName of
- Nothing -> moduleHtmlFile mdl
- Just name -> nameHtmlRef mdl name
+ Nothing -> moduleUrl mdl
+ Just name -> moduleNameUrl mdl name
ppModule :: Module -> String -> Html
ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)]
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 786a4996..a8e2e8e0 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -318,7 +318,7 @@ mkNode ss p (Node s leaf pkg short ts) =
htmlModule = thespan ! [theclass "module" ] <<
(if leaf
then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
- (mkModuleName mdl)) ""
+ (mkModuleName mdl))
else toHtml s
)
@@ -597,8 +597,7 @@ processForMiniSynopsis _ _ _ = Nothing
ppNameMini :: Module -> OccName -> Html
ppNameMini mdl nm =
- anchor ! [ href ( moduleHtmlFile mdl ++ "#"
- ++ (escapeStr (anchorNameStr nm)))
+ anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
<< ppBinder' nm
@@ -656,7 +655,7 @@ processExport summary _ _ (ExportNoDecl y subs)
processExport summary _ _ (ExportDoc doc)
= nothingIf summary $ docSection doc
processExport summary _ _ (ExportModule mdl)
- = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl ""
+ = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
nothingIf :: Bool -> a -> Maybe a
nothingIf True _ = Nothing
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 6563f914..42fc39ca 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -39,7 +39,7 @@ parHtmlMarkup ppId isTyCon = Markup {
markupAppend = (+++),
markupIdentifier = thecode . ppId . choose,
markupModule = \m -> let (mdl,ref) = break (=='#') m
- in ppModule (mkModuleNoPackage mdl) ref,
+ in ppModuleRef (mkModuleNoPackage mdl) ref,
markupEmphasis = emphasize,
markupMonospaced = thecode,
markupUnorderedList = unordList,
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 5b3732c6..b124d42b 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -13,7 +13,7 @@
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName,
ppBinder, ppBinder',
- ppModule,
+ ppModule, ppModuleRef,
linkId
) where
@@ -50,8 +50,8 @@ ppName name = toHtml (getOccString name)
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 (anchorNameStr n) << ppBinder' n
-ppBinder False n = namedAnchor (anchorNameStr n) << bold << ppBinder' n
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
+ppBinder False n = namedAnchor (nameAnchorId n) << bold << ppBinder' n
ppBinder' :: OccName -> Html
@@ -65,13 +65,19 @@ linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)
linkIdOcc :: Module -> Maybe OccName -> Html -> Html
-linkIdOcc mdl mbName = anchor ! [href uri]
+linkIdOcc mdl mbName = anchor ! [href url]
where
- uri = case mbName of
- Nothing -> moduleHtmlFile mdl
- Just name -> nameHtmlRef mdl name
-
-ppModule :: Module -> String -> Html
-ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)]
- << toHtml (moduleString mdl)
-
+ url = case mbName of
+ Nothing -> moduleUrl mdl
+ Just name -> moduleNameUrl mdl name
+
+ppModule :: Module -> Html
+ppModule mdl = anchor ! [href (moduleUrl mdl)]
+ << toHtml (moduleString mdl)
+
+ppModuleRef :: Module -> String -> Html
+ppModuleRef mdl ref = anchor ! [href (moduleUrl mdl ++ ref)]
+ << toHtml (moduleString mdl)
+ -- NB: The ref paramaeter already includes the '#'.
+ -- This function is only called from markupModule expanding a
+ -- DocModule, which doesn't seem to be ever be used.
diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs
index 1fcf5e94..20b246d1 100644
--- a/src/Haddock/Backends/Xhtml/Util.hs
+++ b/src/Haddock/Backends/Xhtml/Util.hs
@@ -157,21 +157,11 @@ dot = toHtml "."
-- | Generate a named anchor
---
--- This used to generate two anchor tags, one with the name unescaped, and one
--- with the name URI-escaped. This is needed because Opera 9.52 (and later
--- versions) needs the name to be unescaped, while IE 7 needs it to be escaped.
--- The escaped form for IE 7 is probably erroneous and not needed...
-
namedAnchor :: String -> Html -> Html
-namedAnchor n c = anchor ! [XHtml.name n] << c
+namedAnchor n = anchor ! [XHtml.name n]
linkedAnchor :: String -> Html -> Html
-linkedAnchor frag = anchor ! [href hr_]
- where hr_ | null frag = ""
- | otherwise = '#': escapeStr frag
- -- this escape function is over-zealous for the fragment part of a URI
- -- (':' for example does not need to be escaped)
+linkedAnchor n = anchor ! [href ('#':n)]
--
-- A section of HTML which is collapsible via a +/- button.
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 396111c1..ffbf7494 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -17,14 +17,18 @@ module Haddock.Utils (
toDescription, toInstalledDescription,
-- * Filename utilities
- moduleHtmlFile, nameHtmlRef,
+ moduleHtmlFile,
contentsHtmlFile, indexHtmlFile,
frameIndexHtmlFile,
moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
- anchorNameStr,
cssFile, iconFile, jsFile, plusFile, minusFile, framesFile,
+ -- * Anchor and URL utilities
+ moduleNameUrl, moduleUrl,
+ nameAnchorId,
+ makeAnchorId,
+
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -58,7 +62,7 @@ import GHC
import Name
import Control.Monad ( liftM )
-import Data.Char ( isAlpha, ord, chr )
+import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
import Numeric ( showIntAtBase )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
@@ -176,9 +180,6 @@ moduleHtmlFile mdl =
(moduleNameString (moduleName mdl))
-nameHtmlRef :: Module -> OccName -> String
-nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n)
-
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
@@ -204,10 +205,42 @@ subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
| otherwise = show (ord a)
-anchorNameStr :: OccName -> String
-anchorNameStr name | isValOcc name = "v:" ++ occNameString name
- | otherwise = "t:" ++ occNameString name
-
+-- -----------------------------------------------------------------------------
+-- Anchor and URL utilities
+--
+-- NB: Anchor IDs, used as the destination of a link within a document must
+-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's
+-- various needs and compatibility constraints, means these IDs have to match:
+-- [A-Za-z][A-Za-z0-9:_.-]*
+-- Such IDs do not need to be escaped in any way when used as the fragment part
+-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it
+-- isn't clear if such fragment identifiers should, or should not be unescaped
+-- before being matched with IDs in the target document.
+
+moduleUrl :: Module -> String
+moduleUrl = moduleHtmlFile
+
+moduleNameUrl :: Module -> OccName -> String
+moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n
+
+nameAnchorId :: OccName -> String
+nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
+ where prefix | isValOcc name = 'v'
+ | otherwise = 't'
+
+-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
+-- identity preserving.
+makeAnchorId :: String -> String
+makeAnchorId [] = []
+makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
+ where
+ escape p c | p c = [c]
+ | otherwise = '-' : (show (ord c)) ++ "-"
+ isLegal ':' = True
+ isLegal '_' = True
+ isLegal '.' = True
+ isLegal c = isAscii c && isAlphaNum c
+ -- NB: '-' is legal in IDs, but we use it as the escape char
-- -----------------------------------------------------------------------------
-- Files we need to copy from our $libdir
@@ -267,7 +300,7 @@ escapeStr = escapeURIString isUnreserved
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
-- (at least if you want to build network with haddock docs)
-
+-- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
| p c = [c]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:08:59 +0000