aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock.cabal2
-rw-r--r--html-test/ref/Bold.html101
-rw-r--r--html-test/src/Bold.hs9
-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
-rw-r--r--test/Haddock/Parser/UtilSpec.hs23
-rw-r--r--test/Haddock/ParserSpec.hs48
15 files changed, 244 insertions, 14 deletions
diff --git a/haddock.cabal b/haddock.cabal
index b2645f50..d3948d22 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -105,6 +105,7 @@ executable haddock
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
Haddock.Parser
+ Haddock.Parser.Util
Haddock.Utf8
Haddock.Utils
Haddock.Backends.Xhtml
@@ -176,6 +177,7 @@ library
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
Haddock.Parser
+ Haddock.Parser.Util
Haddock.Utf8
Haddock.Utils
Haddock.Backends.Xhtml
diff --git a/html-test/ref/Bold.html b/html-test/ref/Bold.html
new file mode 100644
index 00000000..4d5f559a
--- /dev/null
+++ b/html-test/ref/Bold.html
@@ -0,0 +1,101 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >Bold</title
+ ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+ /><script src="haddock-util.js" type="text/javascript"
+ ></script
+ ><script type="text/javascript"
+ >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_Bold.html");};
+//]]>
+</script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="index.html"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="doc-index.html"
+ >Index</a
+ ></li
+ ></ul
+ ><p class="caption empty"
+ >&nbsp;</p
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bold</p
+ ></div
+ ><div id="synopsis"
+ ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+ >Synopsis</p
+ ><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+ ><li class="src short"
+ ><a href="#v:foo"
+ >foo</a
+ > :: t</li
+ ></ul
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:foo" class="def"
+ >foo</a
+ > :: t</p
+ ><div class="doc"
+ ><p
+ >Some <strong
+ >bold text</strong
+ >.</p
+ ><ul
+ ><li
+ ><strong
+ >Bold</strong
+ > in a list
+</li
+ ></ul
+ ><dl
+ ><dt
+ ><strong
+ >bold in a definition</strong
+ ></dt
+ ><dd
+ >list
+</dd
+ ></dl
+ ><pre
+ > bold <strong
+ >in</strong
+ > a <strong
+ >code</strong
+ > block</pre
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ><p
+ >Produced by <a href="http://www.haskell.org/haddock/"
+ >Haddock</a
+ > version 2.14.0</p
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/src/Bold.hs b/html-test/src/Bold.hs
new file mode 100644
index 00000000..7ff28ef9
--- /dev/null
+++ b/html-test/src/Bold.hs
@@ -0,0 +1,9 @@
+module Bold where
+-- | Some __bold text__.
+--
+-- * __Bold__ in a list
+--
+-- [__bold in a definition__] list
+--
+-- @ bold __in__ a __code__ block @
+foo = undefined
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
-
diff --git a/test/Haddock/Parser/UtilSpec.hs b/test/Haddock/Parser/UtilSpec.hs
new file mode 100644
index 00000000..acb88220
--- /dev/null
+++ b/test/Haddock/Parser/UtilSpec.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Haddock.Parser.UtilSpec (main, spec) where
+
+import Test.Hspec
+import Data.Either
+
+import Data.Attoparsec.ByteString.Char8
+import Haddock.Parser.Util
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "takeUntil" $ do
+ it "takes everything until a specified byte sequence" $ do
+ parseOnly (takeUntil "end") "someend" `shouldBe` Right "some"
+
+ it "requires the end sequence" $ do
+ parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft
+
+ it "takes escaped bytes unconditionally" $ do
+ parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end"
diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs
index 42f19c96..8c8e25ca 100644
--- a/test/Haddock/ParserSpec.hs
+++ b/test/Haddock/ParserSpec.hs
@@ -174,7 +174,53 @@ spec = before initStaticOpts $ do
"/foo\\/bar/" `shouldParseTo` DocEmphasis "foo/bar"
it "recognizes other markup constructs within emphasised text" $ do
- "/foo @bar@ baz/" `shouldParseTo` DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz")
+ "/foo @bar@ baz/" `shouldParseTo`
+ DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz")
+
+ it "allows other markup inside of emphasis" $ do
+ "/__inner bold__/" `shouldParseTo` DocEmphasis (DocBold "inner bold")
+
+ it "doesn't mangle inner markup unicode" $ do
+ "/__灼眼のシャナ &#65;__/" `shouldParseTo` DocEmphasis (DocBold "灼眼のシャナ A")
+
+ it "properly converts HTML escape sequences" $ do
+ "/&#65;&#65;&#65;&#65;/" `shouldParseTo` DocEmphasis "AAAA"
+
+ it "allows to escape the emphasis delimiter inside of emphasis" $ do
+ "/empha\\/sis/" `shouldParseTo` DocEmphasis "empha/sis"
+
+ context "when parsing bold strings" $ do
+ it "allows for a bold string on its own" $ do
+ "__bold string__" `shouldParseTo`
+ DocBold "bold string"
+
+ it "bolds inline correctly" $ do
+ "hello __everyone__ there" `shouldParseTo`
+ "hello "
+ <> DocBold "everyone" <> " there"
+
+ it "bolds unicode" $ do
+ "__灼眼のシャナ__" `shouldParseTo`
+ DocBold "灼眼のシャナ"
+
+ it "does not do __multi-line\\n bold__" $ do
+ " __multi-line\n bold__" `shouldParseTo` "__multi-line\n bold__"
+
+ it "allows other markup inside of bold" $ do
+ "__/inner emphasis/__" `shouldParseTo`
+ (DocBold $ DocEmphasis "inner emphasis")
+
+ it "doesn't mangle inner markup unicode" $ do
+ "__/灼眼のシャナ &#65;/__" `shouldParseTo`
+ (DocBold $ DocEmphasis "灼眼のシャナ A")
+
+ it "properly converts HTML escape sequences" $ do
+ "__&#65;&#65;&#65;&#65;__" `shouldParseTo`
+ DocBold "AAAA"
+
+ it "allows to escape the bold delimiter inside of bold" $ do
+ "__bo\\__ld__" `shouldParseTo`
+ DocBold "bo__ld"
context "when parsing monospaced text" $ do
it "parses simple monospaced text" $ do
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 19:48:31 +0000