diff options
| -rw-r--r-- | CHANGES | 2 | ||||
| -rw-r--r-- | html-test/ref/Bug201.html | 102 | ||||
| -rw-r--r-- | html-test/src/Bug201.hs | 28 | ||||
| -rw-r--r-- | src/Haddock/Parser.hs | 31 | ||||
| -rw-r--r-- | test/Haddock/ParserSpec.hs | 28 |
5 files changed, 185 insertions, 6 deletions
@@ -4,6 +4,8 @@ Changes in version 2.15.0 * Print kind signatures GADTs (#85) + * Drop single leading whitespace when reasonable from @-style blocks (#201) + Changes in version 2.14.1 * Render * and -> with their UnicodeSyntax equivalents if -U is enabled diff --git a/html-test/ref/Bug201.html b/html-test/ref/Bug201.html new file mode 100644 index 00000000..893ccbef --- /dev/null +++ b/html-test/ref/Bug201.html @@ -0,0 +1,102 @@ +<!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 + >Bug201</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_Bug201.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </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" + >Bug201</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="" + >f</a + > :: ()</li + ><li class="src short" + ><a href="" + >g</a + > :: ()</li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:f" class="def" + >f</a + > :: ()</p + ><div class="doc" + ><pre + >This leading whitespace +should be dropped +</pre + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:g" class="def" + >g</a + > :: ()</p + ><div class="doc" + ><pre + > But this one + should not +</pre + ><pre + >this should +be dropped</pre + ><pre + >and so should this +because there's a space before closing @ +</pre + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.15.0</p + ></div + ></body + ></html +> diff --git a/html-test/src/Bug201.hs b/html-test/src/Bug201.hs new file mode 100644 index 00000000..bf6cb9a9 --- /dev/null +++ b/html-test/src/Bug201.hs @@ -0,0 +1,28 @@ +-- We test that leading whitespace gets properly dropped (or not!) +-- from codeblocks +module Bug201 where + +-- | +-- @ +-- This leading whitespace +-- should be dropped +-- @ +f :: () +f = () + +{-| +@ + But this one + should not +@ + +> this should +> be dropped + +@ + and so should this + because there's a space before closing @ + @ +-} +g :: () +g = () diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs index cd7bb020..bd5cd200 100644 --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -2,6 +2,7 @@ {-# LANGUAGE StandaloneDeriving , FlexibleInstances, UndecidableInstances , IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -21,7 +22,7 @@ import Control.Applicative import Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine) import qualified Data.ByteString.Char8 as BS import Data.Char (chr, isAsciiUpper) -import Data.List (stripPrefix, intercalate) +import Data.List (stripPrefix, intercalate, unfoldr) import Data.Maybe (fromMaybe) import Data.Monoid import DynFlags @@ -59,7 +60,8 @@ parseParas d = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") p :: Parser (Doc RdrName) p = mconcat <$> paragraph d `sepBy` many (skipHorizontalSpace *> "\n") --- | Parse a text paragraph. +-- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which +-- drops leading whitespace and encodes the string to UTF8 first. parseString :: DynFlags -> String -> Doc RdrName parseString d = parseStringBS d . encodeUtf8 . dropWhile isSpace @@ -366,8 +368,31 @@ property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n') -- for markup. codeblock :: DynFlags -> Parser (Doc RdrName) codeblock d = - DocCodeBlock . parseStringBS d <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") + DocCodeBlock . parseStringBS d . dropSpaces + <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where + dropSpaces xs = + let rs = decodeUtf8 xs + in case splitByNl rs of + [] -> xs + ys -> case last ys of + ' ':_ -> case mapM dropSpace ys of + Nothing -> xs + Just zs -> encodeUtf8 $ intercalate "\n" zs + _ -> xs + + -- This is necessary because ‘lines’ swallows up a trailing newline + -- and we lose information about whether the last line belongs to @ or to + -- text which we need to decide whether we actually want to be dropping + -- anything at all. + splitByNl = unfoldr (\case '\n':s -> Just (span (/= '\n') s) + _ -> Nothing) + . ('\n' :) + + dropSpace "" = Just "" + dropSpace (' ':xs) = Just xs + dropSpace _ = Nothing + block' = scan False p where p isNewline c diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs index db843ccf..f44b7d0f 100644 --- a/test/Haddock/ParserSpec.hs +++ b/test/Haddock/ParserSpec.hs @@ -432,12 +432,34 @@ spec = before initStaticOpts $ do ] `shouldParseTo` DocCodeBlock "foo\n@\nbar\n" it "accepts horizontal space before the @" $ do + unlines [ " @" + , "foo" + , "" + , "bar" + , "@" + ] `shouldParseTo` DocCodeBlock "foo\n\nbar\n" + + it "strips a leading space from a @ block if present" $ do + unlines [ " @" + , " hello" + , " world" + , " @" + ] `shouldParseTo` DocCodeBlock "hello\nworld\n" + unlines [ " @" - , " foo" + , " hello" , "" - , " bar" + , " world" , " @" - ] `shouldParseTo` DocCodeBlock " foo\n\n bar\n " + ] `shouldParseTo` DocCodeBlock "hello\n\nworld\n" + + it "only drops whitespace if there's some before closing @" $ do + unlines [ "@" + , " Formatting" + , " matters." + , "@" + ] + `shouldParseTo` DocCodeBlock " Formatting\n matters.\n" it "accepts unicode" $ do "@foo 灼眼のシャナ bar@" `shouldParseTo` DocCodeBlock "foo 灼眼のシャナ bar" |