Add an optional label to URLs

9 files changed, 37 insertions, 17 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index d27ca80f..25ca65e9 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -247,7 +247,7 @@ markupTag = Markup {
   markupOrderedList          = box (TagL 'o'),
   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
   markupCodeBlock            = box TagPre,
-  markupURL                  = box (TagInline "a") . str,
+  markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
   markupAName                = const $ str "",
   markupExample              = box TagPre . str . unlines . map exampleToString
   }
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 31ba3b0b..ef72505c 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1011,7 +1011,7 @@ parLatexMarkup ppId = Markup {
   markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
   markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
   markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
-  markupURL                  = \u _ -> text "\\url" <> braces (text u),
+  markupHyperlink            = \l _ -> markupLink l,
   markupAName                = \_ _ -> empty,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
   }
@@ -1020,6 +1020,10 @@ parLatexMarkup ppId = Markup {
     fixString Verb  s = s
     fixString Mono  s = latexMonoFilter s
 
+    markupLink (Hyperlink url mLabel) = case mLabel of
+      Just label -> text "\\href" <> braces (text url) <> braces (text label)
+      Nothing    -> text "\\url"  <> braces (text url)
+
     markupId ppId_ id v =
       case v of
         Verb  -> theid
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 052116ee..e75cfaba 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -25,6 +25,7 @@ import Haddock.Types
 import Haddock.Utils
 
 import Text.XHtml hiding ( name, title, p, quote )
+import Data.Maybe (fromMaybe)
 
 import GHC
 
@@ -46,7 +47,7 @@ parHtmlMarkup qual ppId = Markup {
   markupOrderedList          = ordList,
   markupDefList              = defList,
   markupCodeBlock            = pre,
-  markupURL                  = \url -> anchor ! [href url] << url,
+  markupHyperlink            = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel,
   markupAName                = \aname -> namedAnchor aname << "",
   markupPic                  = \path -> image ! [src path],
   markupExample              = examplesToHtml
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 56ed1b42..de006386 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -113,7 +113,7 @@ rename gre = rn
       DocCodeBlock doc -> DocCodeBlock (rn doc)
       DocIdentifierUnchecked x -> DocIdentifierUnchecked x
       DocModule str -> DocModule str
-      DocURL str -> DocURL str
+      DocHyperlink l -> DocHyperlink l
       DocPic str -> DocPic str
       DocAName str -> DocAName str
       DocExamples e -> DocExamples e
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b703da0f..18e5f1d2 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -200,7 +200,7 @@ renameDoc d = case d of
   DocCodeBlock doc -> do
     doc' <- renameDoc doc
     return (DocCodeBlock doc')
-  DocURL str -> return (DocURL str)
+  DocHyperlink l -> return (DocHyperlink l)
   DocPic str -> return (DocPic str)
   DocAName str -> return (DocAName str)
   DocExamples e -> return (DocExamples e)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 970093df..ebe15325 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -66,13 +66,13 @@ binaryInterfaceMagic = 0xD0Cface
 -- we version our interface files accordingly.
 binaryInterfaceVersion :: Word16
 #if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 21
 #elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 21
 #elif __GLASGOW_HASKELL__ == 704
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 21
 #elif __GLASGOW_HASKELL__ == 705
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 21
 #else
 #error Unknown GHC version
 #endif
@@ -413,6 +413,15 @@ instance Binary Example where
         result <- get bh
         return (Example expression result)
 
+instance Binary Hyperlink where
+    put_ bh (Hyperlink url label) = do
+        put_ bh url
+        put_ bh label
+    get bh = do
+        url <- get bh
+        label <- get bh
+        return (Hyperlink url label)
+
 
 {-* Generated by DrIFT : Look, but Don't Touch. *-}
 instance (Binary id) => Binary (Doc id) where
@@ -452,7 +461,7 @@ instance (Binary id) => Binary (Doc id) where
     put_ bh (DocCodeBlock al) = do
             putByte bh 11
             put_ bh al
-    put_ bh (DocURL am) = do
+    put_ bh (DocHyperlink am) = do
             putByte bh 12
             put_ bh am
     put_ bh (DocPic x) = do
@@ -511,7 +520,7 @@ instance (Binary id) => Binary (Doc id) where
                     return (DocCodeBlock al)
               12 -> do
                     am <- get bh
-                    return (DocURL am)
+                    return (DocHyperlink am)
               13 -> do
                     x <- get bh
                     return (DocPic x)
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index e36e8416..0cc783ee 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -10,7 +10,7 @@
 module Haddock.Parse where
 
 import Haddock.Lex
-import Haddock.Types (Doc(..), Example(Example))
+import Haddock.Types (Doc(..), Example(Example), Hyperlink(..))
 import Haddock.Doc
 import HsSyn
 import RdrName
@@ -107,7 +107,7 @@ seq1	:: { Doc RdrName }
 elem1	:: { Doc RdrName }
 	: STRING		{ DocString $1 }
 	| '/../'                { DocEmphasis (DocString $1) }
-	| URL			{ DocURL $1 }
+	| URL			{ DocHyperlink (Hyperlink $1 Nothing) }
 	| PIC                   { DocPic $1 }
 	| ANAME			{ DocAName $1 }
 	| IDENT			{ DocIdentifier $1 }
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 048a7ff7..f8890ebf 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -303,7 +303,7 @@ data Doc id
   | DocOrderedList [Doc id]
   | DocDefList [(Doc id, Doc id)]
   | DocCodeBlock (Doc id)
-  | DocURL String
+  | DocHyperlink Hyperlink
   | DocPic String
   | DocAName String
   | DocExamples [Example]
@@ -315,6 +315,12 @@ instance Monoid (Doc id) where
   mappend = DocAppend
 
 
+data Hyperlink = Hyperlink
+  { hyperlinkUrl   :: String
+  , hyperlinkLabel :: Maybe String
+  }
+
+
 data Example = Example
   { exampleExpression :: String
   , exampleResult     :: [String]
@@ -341,7 +347,7 @@ data DocMarkup id a = Markup
   , markupOrderedList          :: [a] -> a
   , markupDefList              :: [(a,a)] -> a
   , markupCodeBlock            :: a -> a
-  , markupURL                  :: String -> a
+  , markupHyperlink            :: Hyperlink -> a
   , markupAName                :: String -> a
   , markupPic                  :: String -> a
   , markupExample              :: [Example] -> a
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 3a2f1d28..ad61e88a 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -416,7 +416,7 @@ markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
 markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)
 markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
 markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
-markup m (DocURL url)                = markupURL m url
+markup m (DocHyperlink l)            = markupHyperlink m l
 markup m (DocAName ref)              = markupAName m ref
 markup m (DocPic img)                = markupPic m img
 markup m (DocExamples e)             = markupExample m e
@@ -443,7 +443,7 @@ idMarkup = Markup {
   markupOrderedList          = DocOrderedList,
   markupDefList              = DocDefList,
   markupCodeBlock            = DocCodeBlock,
-  markupURL                  = DocURL,
+  markupHyperlink            = DocHyperlink,
   markupAName                = DocAName,
   markupPic                  = DocPic,
   markupExample              = DocExamples