aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Backends/Hoogle.hs7
-rw-r--r--src/Haddock/Backends/LaTeX.hs3
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs1
-rw-r--r--src/Haddock/Interface/LexParseRn.hs1
-rw-r--r--src/Haddock/Interface/Rename.hs4
-rw-r--r--src/Haddock/InterfaceFile.hs6
-rw-r--r--src/Haddock/Parser.hs15
-rw-r--r--src/Haddock/Parser/Util.hs22
-rw-r--r--src/Haddock/Types.hs5
-rw-r--r--src/Haddock/Utils.hs11
10 files changed, 62 insertions, 13 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 6afc7939..521b0c90 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -11,7 +11,7 @@
-- Write out Hoogle compatible documentation
-- http://www.haskell.org/hoogle/
-----------------------------------------------------------------------------
-module Haddock.Backends.Hoogle (
+module Haddock.Backends.Hoogle (
ppHoogle
) where
@@ -160,7 +160,7 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
= showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
-
+
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
@@ -194,7 +194,7 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
name = out dflags $ unL $ con_name con
resType = case con_res con of
- ResTyH98 -> apps $ map (reL . HsTyVar) $
+ ResTyH98 -> apps $ map (reL . HsTyVar) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
ResTyGADT x -> x
@@ -247,6 +247,7 @@ markupTag dflags = Markup {
markupModule = box (TagInline "a") . str,
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
+ markupBold = box (TagInline "b"),
markupMonospaced = box (TagInline "tt"),
markupPic = const $ str " ",
markupUnorderedList = box (TagL 'u'),
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 64966ac2..f4edb5fc 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1003,6 +1003,7 @@ parLatexMarkup ppId = Markup {
markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
markupWarning = \p v -> emph (p v),
markupEmphasis = \p v -> emph (p v),
+ markupBold = \p v -> bold (p v),
markupMonospaced = \p _ -> tt (p Mono),
markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
markupPic = \p _ -> markupPic p,
@@ -1114,6 +1115,8 @@ decltt ltx = text "\\haddockdecltt" <> braces ltx
emph :: LaTeX -> LaTeX
emph ltx = text "\\emph" <> braces ltx
+bold :: LaTeX -> LaTeX
+bold ltx = text "\\textbf" <> braces ltx
verb :: LaTeX -> LaTeX
verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 31d653bc..ee77012f 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -43,6 +43,7 @@ parHtmlMarkup qual ppId = Markup {
in ppModuleRef (mkModuleName mdl) ref,
markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
+ markupBold = strong,
markupMonospaced = thecode,
markupUnorderedList = unordList,
markupOrderedList = ordList,
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 8c33ade6..041b5be1 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -110,6 +110,7 @@ rename dflags gre = rn
DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
+ DocBold doc -> DocBold (rn doc)
DocMonospaced doc -> DocMonospaced (rn doc)
DocUnorderedList docs -> DocUnorderedList (map rn docs)
DocOrderedList docs -> DocOrderedList (map rn docs)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 97a63b34..9a4041ee 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -443,7 +443,7 @@ renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
= do { tc' <- renameL tc
; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
- ; rhs' <- renameLType rhs
+ ; rhs' <- renameLType rhs
; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
, tfie_rhs = rhs' }) }
@@ -451,7 +451,7 @@ renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
= do { tc' <- renameL tc
; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
- ; defn' <- renameDataDefn defn
+ ; defn' <- renameDataDefn defn
; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 189550b8..3024f212 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -498,6 +498,9 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocProperty x) = do
putByte bh 18
put_ bh x
+ put_ bh (DocBold x) = do
+ putByte bh 19
+ put_ bh x
get bh = do
h <- getByte bh
case h of
@@ -558,6 +561,9 @@ instance (Binary id) => Binary (Doc id) where
18 -> do
x <- get bh
return (DocProperty x)
+ 19 -> do
+ x <- get bh
+ return (DocBold x)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs
index fe8904d4..58d047f7 100644
--- a/src/Haddock/Parser.hs
+++ b/src/Haddock/Parser.hs
@@ -30,6 +30,7 @@ import RdrName
import SrcLoc (mkRealSrcLoc, unLoc)
import StringBuffer (stringToStringBuffer)
import Haddock.Utf8
+import Haddock.Parser.Util
{-# DEPRECATED parseParasMaybe "use `parseParas` instead" #-}
parseParasMaybe :: DynFlags -> String -> Maybe (Doc RdrName)
@@ -63,7 +64,7 @@ parseStringBS d = parse p
where
p :: Parser (Doc RdrName)
p = mconcat <$> many (monospace d <|> anchor <|> identifier d
- <|> moduleName <|> picture <|> hyperlink <|> autoUrl
+ <|> moduleName <|> picture <|> hyperlink <|> autoUrl <|> bold d
<|> emphasis d <|> encodedChar <|> string' <|> skipSpecialChar)
-- | Parses and processes
@@ -79,7 +80,7 @@ encodedChar = "&#" *> c <* ";"
hex = ("x" <|> "X") *> hexadecimal
specialChar :: [Char]
-specialChar = "/<@\"&'`"
+specialChar = "_/<@\"&'`"
-- | Plain, regular parser for text. Called as one of the last parsers
-- to ensure that we have already given a chance to more meaningful parsers
@@ -105,6 +106,16 @@ emphasis :: DynFlags -> Parser (Doc RdrName)
emphasis d = DocEmphasis . parseStringBS d <$>
mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/")
+-- | Bold parser.
+--
+-- >>> parseOnly bold "__Hello world__"
+-- Right (DocBold (DocString "Hello world"))
+bold :: DynFlags -> Parser (Doc RdrName)
+bold d = DocBold . parseStringBS d <$> disallowNewline ("__" *> takeUntil "__")
+
+disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString
+disallowNewline = mfilter ('\n' `BS.notElem`)
+
-- | Like `takeWhile`, but unconditionally take escaped characters.
takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString
takeWhile_ p = scan False p_
diff --git a/src/Haddock/Parser/Util.hs b/src/Haddock/Parser/Util.hs
new file mode 100644
index 00000000..ea682601
--- /dev/null
+++ b/src/Haddock/Parser/Util.hs
@@ -0,0 +1,22 @@
+module Haddock.Parser.Util where
+
+import Control.Applicative
+import Control.Monad
+import Data.Attoparsec.ByteString.Char8
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as BS
+
+takeUntil :: ByteString -> Parser ByteString
+takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p)
+ where
+ end = BS.unpack end_
+
+ p :: (Bool, String) -> Char -> Maybe (Bool, String)
+ p acc c = case acc of
+ (True, _) -> Just (False, end)
+ (_, []) -> Nothing
+ (_, x:xs) | x == c -> Just (False, xs)
+ _ -> Just (c == '\\', end)
+
+ dropEnd = BS.reverse . BS.drop (length end) . BS.reverse
+ requireEnd = mfilter (BS.isSuffixOf end_)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 00a8b68f..b847bfdb 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, GADTs #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -299,6 +299,7 @@ data Doc id
| DocWarning (Doc id)
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
+ | DocBold (Doc id)
| DocUnorderedList [Doc id]
| DocOrderedList [Doc id]
| DocDefList [(Doc id, Doc id)]
@@ -321,6 +322,7 @@ instance NFData a => NFData (Doc a) where
DocModule a -> a `deepseq` ()
DocWarning a -> a `deepseq` ()
DocEmphasis a -> a `deepseq` ()
+ DocBold a -> a `deepseq` ()
DocMonospaced a -> a `deepseq` ()
DocUnorderedList a -> a `deepseq` ()
DocOrderedList a -> a `deepseq` ()
@@ -382,6 +384,7 @@ data DocMarkup id a = Markup
, markupModule :: String -> a
, markupWarning :: a -> a
, markupEmphasis :: a -> a
+ , markupBold :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
, markupOrderedList :: [a] -> a
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index e0b86350..eccf81ed 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -36,7 +36,7 @@ module Haddock.Utils (
-- * HTML cross reference mapping
html_xrefs_ref, html_xrefs_ref',
- -- * Doc markup
+ -- * Doc markup
markup,
idMarkup,
@@ -126,7 +126,7 @@ toInstalledDescription = hmi_description . instInfo
restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d ->
+ TyClD d | isDataDecl d ->
TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
TyClD d | isClassDecl d ->
TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
@@ -239,7 +239,7 @@ subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
-- 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
@@ -285,7 +285,7 @@ framesFile = "frames.html"
-------------------------------------------------------------------------------
--- * Misc.
+-- * Misc.
-------------------------------------------------------------------------------
@@ -422,6 +422,7 @@ markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
markup m (DocModule mod0) = markupModule m mod0
markup m (DocWarning d) = markupWarning m (markup m d)
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (DocBold d) = markupBold m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
@@ -450,6 +451,7 @@ idMarkup = Markup {
markupModule = DocModule,
markupWarning = DocWarning,
markupEmphasis = DocEmphasis,
+ markupBold = DocBold,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
@@ -474,4 +476,3 @@ foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int ==
getProcessID :: IO Int
getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid
#endif
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:30:55 +0000