[haddock @ 2002-07-25 14:37:28 by simonmar]

Patch to allow simple hyperlinking to an arbitrary location in another
module's documentation, from Volker Stolz.

Now in a doc comment:

  #foo#

creates

  <a name="foo"></a>

And you can use the form "M\#foo" to hyperlink to the label 'foo' in
module 'M'.  Note that the backslash is necessary for now.

5 files changed, 18 insertions, 8 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index cdca7672..7009ba89 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -852,10 +852,11 @@ linkId (Module mdl) str = moduleHtmlFile fp mdl ++ '#': hsNameStr str
 		Nothing  -> ""
 
 ppHsModule :: String -> Html
-ppHsModule mdl = anchor ! [href (moduleHtmlFile fp mdl)] << toHtml mdl
-  where fp = case lookupFM html_xrefs (Module mdl) of
+ppHsModule mdl = anchor ! [href ((moduleHtmlFile fp modname) ++ ref)] << toHtml mdl
+  where fp = case lookupFM html_xrefs (Module modname) of
 		Just fp0 -> fp0 
 		Nothing  -> ""
+        (modname,ref) = break (== '#') mdl
 
 -- -----------------------------------------------------------------------------
 -- * Doc Markup
@@ -872,7 +873,8 @@ htmlMarkup = Markup {
   markupUnorderedList = ulist . concatHtml . map (li <<),
   markupOrderedList   = olist . concatHtml . map (li <<),
   markupCodeBlock     = pre,
-  markupURL	      = \url -> anchor ! [href url] << toHtml url
+  markupURL	      = \url -> anchor ! [href url] << toHtml url,
+  markupAName	      = \aname -> anchor ! [name aname] << toHtml ""
   }
 
 -- If the doc is a single paragraph, don't surround it with <P> (this causes
diff --git a/src/HaddockLex.hs b/src/HaddockLex.hs
index fdfc743a..b1de971e 100644
--- a/src/HaddockLex.hs
+++ b/src/HaddockLex.hs
@@ -23,10 +23,11 @@ data Token
   | TokString String
   | TokURL String
   | TokBirdTrack
+  | TokAName String
   deriving Show
 
 isSpecial, isSingleQuote, isIdent :: Char -> Bool
-isSpecial c     = c `elem` ['\"', '@', '/']
+isSpecial c     = c `elem` ['\"', '@', '/', '#']
 isSingleQuote c = c `elem` ['\'', '`']
 isIdent c       = isAlphaNum c || c `elem` "_.!#$%&*+/<=>?@\\^|-~"
 
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index d9de9110..15eda968 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -10,6 +10,7 @@ import HsSyn
 %token	'/'	{ TokSpecial '/' }
 	'@'	{ TokSpecial '@' }
 	DQUO 	{ TokSpecial '\"' }
+	'#'	{ TokSpecial '#' }
 	URL	{ TokURL $$ }
 	'*'	{ TokBullet }
 	'(n)'	{ TokNumber }
@@ -65,6 +66,7 @@ seq1	:: { Doc }
 elem1	:: { Doc }
 	: STRING		{ DocString $1 }
 	| '/' STRING '/'	{ DocEmphasis (DocString $2) }
+	| '#' STRING '#'	{ DocAName $2 }
 	| URL			{ DocURL $1 }
 	| IDENT			{ DocIdentifier $1 }
 	| DQUO STRING DQUO	{ DocModule $2 }
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 2717e605..77983e02 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -187,7 +187,8 @@ markupRename = Markup {
   markupUnorderedList = liftM DocUnorderedList . sequence,
   markupOrderedList   = liftM DocOrderedList . sequence,
   markupCodeBlock     = liftM DocCodeBlock,
-  markupURL	      = return . DocURL
+  markupURL	      = return . DocURL,
+  markupAName	      = return . DocAName
   }
 
 renameDoc :: Doc -> RnM Doc
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 77a621df..cde2ce63 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.13 2002/07/24 09:42:18 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.14 2002/07/25 14:37:29 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -392,6 +392,7 @@ data GenDoc id
   | DocOrderedList [GenDoc id]
   | DocCodeBlock (GenDoc id)
   | DocURL String
+  | DocAName String
   deriving (Eq, Show)
 
 type Doc = GenDoc [HsQName]
@@ -412,7 +413,8 @@ data DocMarkup id a = Markup {
   markupUnorderedList :: [a] -> a,
   markupOrderedList   :: [a] -> a,
   markupCodeBlock     :: a -> a,
-  markupURL	      :: String -> a
+  markupURL	      :: String -> a,
+  markupAName	      :: String -> a
   }
 
 markup :: DocMarkup id a -> GenDoc id -> a
@@ -428,6 +430,7 @@ markup m (DocUnorderedList ds)	= markupUnorderedList m (map (markup m) ds)
 markup m (DocOrderedList ds)	= markupOrderedList m (map (markup m) ds)
 markup m (DocCodeBlock d)	= markupCodeBlock m (markup m d)
 markup m (DocURL url)		= markupURL m url
+markup m (DocAName ref)		= markupAName m ref
 
 -- | Since marking up is just a matter of mapping 'Doc' into some
 -- other type, we can \'rename\' documentation by marking up 'Doc' into
@@ -445,7 +448,8 @@ mapIdent f = Markup {
   markupUnorderedList = DocUnorderedList,
   markupOrderedList   = DocOrderedList,
   markupCodeBlock     = DocCodeBlock,
-  markupURL	      = DocURL
+  markupURL	      = DocURL,
+  markupAName	      = DocAName
   }
 
 -- -----------------------------------------------------------------------------