From d3ebf5f25ead73877b38302cbe8b1ed13e993917 Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Mon, 19 Jul 2010 05:20:53 +0000 Subject: refactoring of anchor ID and fragment handling --- src/Haddock/Backends/DevHelp.hs | 2 +- src/Haddock/Backends/HH.hs | 2 +- src/Haddock/Backends/HH2.hs | 2 +- src/Haddock/Backends/Html.hs | 11 +++---- src/Haddock/Backends/Xhtml.hs | 7 ++--- src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- src/Haddock/Backends/Xhtml/Names.hs | 30 +++++++++++------- src/Haddock/Backends/Xhtml/Util.hs | 14 ++------- src/Haddock/Utils.hs | 55 ++++++++++++++++++++++++++------- 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 "text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$ + text "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 " text (nameHtmlRef mdl name) <> text "\">" $$ + text " 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 "" $$ ppList vs - ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" + ppJump name (Module mdl) = text " 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] -- cgit v1.2.3