aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGES2
-rw-r--r--html-test/ref/Bug201.html102
-rw-r--r--html-test/src/Bug201.hs28
-rw-r--r--src/Haddock/Parser.hs31
-rw-r--r--test/Haddock/ParserSpec.hs28
5 files changed, 185 insertions, 6 deletions
diff --git a/CHANGES b/CHANGES
index 31851e5d..5f019025 100644
--- a/CHANGES
+++ b/CHANGES
@@ -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"
+ >&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"
+ >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"