From ef9aa98d6ccbe79888c501f94c9aa6688520c28e Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 10 Jan 2014 05:37:17 +0000 Subject: Support for bold. Conflicts: src/Haddock/Backends/Hoogle.hs src/Haddock/Interface/Rename.hs src/Haddock/Parser.hs --- haddock.cabal | 2 + html-test/ref/Bold.html | 101 ++++++++++++++++++++++++++++++++ html-test/src/Bold.hs | 9 +++ src/Haddock/Backends/Hoogle.hs | 7 ++- src/Haddock/Backends/LaTeX.hs | 3 + src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + src/Haddock/Interface/LexParseRn.hs | 1 + src/Haddock/Interface/Rename.hs | 4 +- src/Haddock/InterfaceFile.hs | 6 ++ src/Haddock/Parser.hs | 15 ++++- src/Haddock/Parser/Util.hs | 22 +++++++ src/Haddock/Types.hs | 5 +- src/Haddock/Utils.hs | 11 ++-- test/Haddock/Parser/UtilSpec.hs | 23 ++++++++ test/Haddock/ParserSpec.hs | 48 ++++++++++++++- 15 files changed, 244 insertions(+), 14 deletions(-) create mode 100644 html-test/ref/Bold.html create mode 100644 html-test/src/Bold.hs create mode 100644 src/Haddock/Parser/Util.hs create mode 100644 test/Haddock/Parser/UtilSpec.hs 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 @@ + +Bold

Safe Haskell	Safe-Inferred

Bold

Synopsis

Documentation

foo :: t

Some bold text.

Bold in a list +

bold in a definition: list +

 bold in a code block

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 + "/__灼眼のシャナ A__/" `shouldParseTo` DocEmphasis (DocBold "灼眼のシャナ A") + + it "properly converts HTML escape sequences" $ do + "/AAAA/" `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 + "__/灼眼のシャナ A/__" `shouldParseTo` + (DocBold $ DocEmphasis "灼眼のシャナ A") + + it "properly converts HTML escape sequences" $ do + "__AAAA__" `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 -- cgit v1.2.3