Support for bold.

Conflicts:
	src/Haddock/Backends/Hoogle.hs
	src/Haddock/Interface/Rename.hs
	src/Haddock/Parser.hs

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
-