Support for bold.

Conflicts: src/Haddock/Backends/Hoogle.hs src/Haddock/Interface/Rename.hs src/Haddock/Parser.hs
author: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> 2014-01-10 05:37:17 +0000
committer: Austin Seipp <austin@well-typed.com> 2014-01-12 14:48:35 -0600
commit: ef9aa98d6ccbe79888c501f94c9aa6688520c28e (patch)
tree: c8b86e469383ebcac5472300608355d410e6942a
parent: d08865e42e7b03348549b79cdc251f444516bc34 (diff)
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
author	Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>	2014-01-10 05:37:17 +0000
committer	Austin Seipp <austin@well-typed.com>	2014-01-12 14:48:35 -0600
commit	ef9aa98d6ccbe79888c501f94c9aa6688520c28e (patch)
tree	c8b86e469383ebcac5472300608355d410e6942a
parent	d08865e42e7b03348549b79cdc251f444516bc34 (diff)