aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/.ghci2
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Backends/LaTeX.hs6
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs3
-rw-r--r--src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--src/Haddock/Interface/Create.hs3
-rw-r--r--src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--src/Haddock/Interface/Rename.hs2
-rw-r--r--src/Haddock/InterfaceFile.hs25
-rw-r--r--src/Haddock/Parse.y13
-rw-r--r--src/Haddock/Types.hs10
-rw-r--r--src/Haddock/Utils.hs5
-rw-r--r--src/Main.hs2
13 files changed, 54 insertions, 23 deletions
diff --git a/src/.ghci b/src/.ghci
index f00e6d55..3e83f04c 100644
--- a/src/.ghci
+++ b/src/.ghci
@@ -1 +1 @@
-:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h -XCPP -XDeriveDataTypeable -XScopedTypeVariables -XMagicHash
+:set -i../dist/build/autogen -i../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../dist/build/autogen/cabal_macros.h
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 55f6ac1d..4949daa1 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -254,7 +254,7 @@ markupTag dflags = 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 c187f104..68cf715a 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1001,7 +1001,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
}
@@ -1010,6 +1010,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/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index a4d4764e..50451666 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 4bb46cba..64995a5f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -688,6 +688,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
f x xs = x : xs
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
@@ -762,7 +763,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- | Keep exprt items with docs.
+-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
where
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index d68f78f8..a5eb1143 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -115,7 +115,7 @@ rename dflags 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 6109c341..0f702683 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -199,7 +199,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 c2f1eb5c..8fa8ce95 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -66,15 +66,15 @@ 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
#elif __GLASGOW_HASKELL__ == 706
-binaryInterfaceVersion = 20
+binaryInterfaceVersion = 21
#else
#error Unknown GHC version
#endif
@@ -415,6 +415,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
@@ -454,7 +463,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
@@ -513,7 +522,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..b34b14b9 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 (makeHyperlink $1) }
| PIC { DocPic $1 }
| ANAME { DocAName $1 }
| IDENT { DocIdentifier $1 }
@@ -121,6 +121,15 @@ strings :: { String }
happyError :: [LToken] -> Maybe a
happyError toks = Nothing
+-- | Create a `Hyperlink` from given string.
+--
+-- A hyperlink consists of a URL and an optional label. The label is separated
+-- from the url by one or more whitespace characters.
+makeHyperlink :: String -> Hyperlink
+makeHyperlink input = case break isSpace $ strip input of
+ (url, "") -> Hyperlink url Nothing
+ (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label)
+
-- | Create an 'Example', stripping superfluous characters as appropriate
makeExample :: String -> String -> [String] -> Example
makeExample prompt expression result =
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 3cadf33a..e1e7ce4b 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
+ } deriving (Eq, Show)
+
+
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 53e8bba8..b8f32589 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
@@ -428,7 +429,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
@@ -455,7 +456,7 @@ idMarkup = Markup {
markupOrderedList = DocOrderedList,
markupDefList = DocDefList,
markupCodeBlock = DocCodeBlock,
- markupURL = DocURL,
+ markupHyperlink = DocHyperlink,
markupAName = DocAName,
markupPic = DocPic,
markupExample = DocExamples
diff --git a/src/Main.hs b/src/Main.hs
index beb01b86..31e2726c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 07:45:47 +0000