Add spec tests.

This adds tests for all elements we can create during regular
parsing. This also adds tests for text with unicode in it.

2 files changed, 383 insertions, 25 deletions

diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs
index ca3b6658..18555cfb 100644
--- a/src/Haddock/Doc.hs
+++ b/src/Haddock/Doc.hs
@@ -1,12 +1,13 @@
 module Haddock.Doc (
   docAppend,
-  docParagraph
+  docParagraph,
+  combineStringNodes
   ) where
 
 
 import Haddock.Types
 import Data.Char (isSpace)
-
+import Control.Arrow ((***))
 
 -- used to make parsing easier; we group the list items later
 docAppend :: Doc id -> Doc id -> Doc id
@@ -63,3 +64,25 @@ docCodeBlock (DocString s)
 docCodeBlock (DocAppend l r)
   = DocAppend l (docCodeBlock r)
 docCodeBlock d = d
+
+-- | This is a hack that joins neighbouring 'DocString's into a single one.
+-- This is done to ease up the testing and doesn't change the final result
+-- as this would be done later anyway.
+combineStringNodes :: Doc id -> Doc id
+combineStringNodes (DocAppend (DocString x) (DocString y)) = DocString (x ++ y)
+combineStringNodes (DocAppend (DocString x) (DocAppend (DocString y) z)) =
+  tryjoin (DocAppend (DocString (x ++ y)) (combineStringNodes z))
+combineStringNodes (DocAppend x y) = tryjoin (DocAppend (combineStringNodes x) (combineStringNodes y))
+combineStringNodes (DocParagraph x) = DocParagraph (combineStringNodes x)
+combineStringNodes (DocWarning x) = DocWarning (combineStringNodes x)
+combineStringNodes (DocEmphasis x) = DocEmphasis (combineStringNodes x)
+combineStringNodes (DocMonospaced x) = DocMonospaced (combineStringNodes x)
+combineStringNodes (DocUnorderedList xs) = DocUnorderedList (map combineStringNodes xs)
+combineStringNodes (DocOrderedList x) = DocOrderedList (map combineStringNodes x)
+combineStringNodes (DocDefList xs) = DocDefList (map (combineStringNodes *** combineStringNodes) xs)
+combineStringNodes (DocCodeBlock x) = DocCodeBlock (combineStringNodes x)
+combineStringNodes x = x
+
+tryjoin :: Doc id -> Doc id
+tryjoin (DocAppend (DocString x) (DocString y)) = DocString (x ++ y)
+tryjoin x = x
diff --git a/test/Haddock/ParseSpec.hs b/test/Haddock/ParseSpec.hs
index d692cb0c..4713c60b 100644
--- a/test/Haddock/ParseSpec.hs
+++ b/test/Haddock/ParseSpec.hs
@@ -1,16 +1,21 @@
-{-# LANGUAGE OverloadedStrings, StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-}
+{-# LANGUAGE OverloadedStrings, StandaloneDeriving
+             , FlexibleInstances, UndecidableInstances
+             , IncoherentInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Haddock.ParseSpec (main, spec) where
 
-import           Test.Hspec
-import           RdrName (RdrName)
+import           Control.Applicative
+import           Data.Monoid
+import           Data.String
 import           DynFlags (DynFlags, defaultDynFlags)
+import           Haddock.Doc (combineStringNodes)
 import           Haddock.Lex (tokenise)
 import qualified Haddock.Parse as Parse
 import           Haddock.Types
 import           Outputable (Outputable, showSDoc, ppr)
-import           Data.Monoid
-import           Data.String
+import           RdrName (RdrName)
+import           Test.Hspec
 
 dynFlags :: DynFlags
 dynFlags = defaultDynFlags (error "dynFlags for Haddock tests: undefined")
@@ -19,63 +24,393 @@ instance Outputable a => Show a where
   show = showSDoc dynFlags . ppr
 
 deriving instance Show a => Show (Doc a)
-deriving instance Eq a =>Eq (Doc a)
+deriving instance Eq a => Eq (Doc a)
+
 
 instance IsString (Doc RdrName) where
   fromString = DocString
 
+instance IsString a => IsString (Maybe a) where
+  fromString = Just . fromString
+
 parseParas :: String -> Maybe (Doc RdrName)
 parseParas s = Parse.parseParas $ tokenise dynFlags s (0,0)
 
+parseString :: String -> Maybe (Doc RdrName)
+parseString s = Parse.parseString $ tokenise dynFlags s (0,0)
+
 main :: IO ()
 main = hspec spec
 
+infix 1 `shouldParseTo`
+shouldParseTo :: String -> Doc RdrName -> Expectation
+shouldParseTo input ast = (combineStringNodes <$> parseParas input)
+                          `shouldBe` Just ast
+
 spec :: Spec
 spec = do
   describe "parseParas" $ do
     it "parses a paragraph" $ do
-      parseParas "foobar" `shouldBe` Just (DocParagraph "foobar\n")
+      "foobar" `shouldParseTo` DocParagraph "foobar\n"
+
+    context "when parsing a simple string" $ do
+      it "] should be made into a DocString" $ do
+        "hell]o" `shouldParseTo` DocParagraph "hell]o\n"
+
+      it "can handle unicode" $ do
+        "灼眼のシャナ" `shouldParseTo` DocParagraph "灼眼のシャナ\n"
+
+    context "when parsing module strings" $ do
+      it "should parse a module on its own" $ do
+        "\"Module\"" `shouldParseTo`
+          (DocParagraph $ DocModule "Module" <> "\n")
+
+      it "should parse a module inline" $ do
+        "This is a \"Module\"." `shouldParseTo`
+          DocParagraph ("This is a " <> ((DocModule "Module") <> ".\n"))
+
+    context "when parsing emphasised strings" $ do
+      it "emphasises a word on its own" $ do
+        "/quux/" `shouldParseTo` (DocParagraph $ DocEmphasis "quux" <> "\n")
+
+      it "emphasises inline correctly" $ do
+        "This comment applies to the /following/ declaration" `shouldParseTo`
+          (DocParagraph $ "This comment applies to the "
+                <> DocEmphasis "following" <> " declaration\n")
+
+      it "emphasises unicode" $ do
+        "/灼眼のシャナ/" `shouldParseTo`
+          (DocParagraph $ DocEmphasis "灼眼のシャナ" <> "\n")
+
+      it "does /multi-line\\n codeblocks/" $ do
+        " /multi-line\n emphasis/" `shouldParseTo`
+          DocParagraph "/multi-line\n emphasis/\n"
+
+    context "when parsing codeblocks" $ do
+      it "codeblock a word on its own" $ do
+        "@quux@" `shouldParseTo` DocCodeBlock "quux"
+
+      it "codeblocks unicode" $ do
+        "@灼眼のシャナ@" `shouldParseTo` DocCodeBlock "灼眼のシャナ"
+
+
+      it "does @multi-line\\n codeblocks@" $ do
+        "@multi-line\n codeblocks@" `shouldParseTo`
+          DocCodeBlock "multi-line\n codeblocks"
+
+      it "accepts other elements in a codeblock" $ do
+        "@/emphasis/ \"Module\" <<picture>>@" `shouldParseTo`
+          (DocCodeBlock $ DocEmphasis "emphasis" <> " "
+                <> DocModule "Module" <> " " <> DocPic "picture")
+
+    context "when parsing monospaced strings" $ do
+      it "monospaces inline strings" $ do
+        "This comment applies to the @following@ declaration" `shouldParseTo`
+          (DocParagraph $ "This comment applies to the "
+                <> DocMonospaced "following" <> " declaration\n")
+
+      it "monospaces inline unicode" $ do
+        "hello @灼眼のシャナ@ unicode" `shouldParseTo`
+          (DocParagraph $ "hello "
+                <> DocMonospaced "灼眼のシャナ" <> " unicode\n")
+
+      it "accepts other elements in a monospaced section" $ do
+        "hey @/emphasis/ \"Module\" <<picture>>@ world" `shouldParseTo`
+          (DocParagraph $
+               "hey "
+            <> DocMonospaced (DocEmphasis "emphasis" <> " "
+                              <> DocModule "Module" <> " " <> DocPic "picture")
+            <> " world\n")
+
+
+    context "when parsing unordered lists" $ do
+      it "parses a simple unordered list" $ do
+        "* point one\n\n* point two" `shouldParseTo`
+          DocUnorderedList [ DocParagraph " point one\n"
+                                 , DocParagraph " point two\n"]
+
+      it "parses an empty unordered list" $ do
+        "*" `shouldParseTo` DocUnorderedList [DocParagraph "\n"]
+
+      it "accepts unicode in an unordered list" $ do
+        "* 灼眼のシャナ" `shouldParseTo`
+          DocUnorderedList [DocParagraph " 灼眼のシャナ\n"]
+
+      it "accepts other elements in an unordered list" $ do
+        ("* \"Module\"\n\n* /emphasis/"
+                    ++ "\n\n* @code@\n\n* a@mono@b \n\n*") `shouldParseTo`
+          DocUnorderedList [
+              DocParagraph (" " <> DocModule "Module" <> "\n")
+            , DocParagraph (" " <> DocEmphasis "emphasis" <> "\n")
+            , DocCodeBlock "code"
+            , DocParagraph (" a" <> (DocMonospaced "mono") <> "b \n")
+            , DocParagraph "\n"
+            ]
+
+    context "when parsing ordered lists" $ do
+      it "parses a simple ordered list" $ do
+        "1. point one\n\n2. point two" `shouldParseTo`
+          DocOrderedList [
+              DocParagraph " point one\n"
+            , DocParagraph " point two\n"
+            ]
+
+      it "parses an empty list" $ do
+        "1." `shouldParseTo` DocOrderedList [DocParagraph "\n"]
+
+        "(1)" `shouldParseTo` DocOrderedList [DocParagraph "\n"]
+
+      it "accepts unicode" $ do
+        "1. 灼眼のシャナ" `shouldParseTo`
+          DocOrderedList [DocParagraph " 灼眼のシャナ\n"]
+
+        "(1) 灼眼のシャナ" `shouldParseTo`
+          DocOrderedList [DocParagraph " 灼眼のシャナ\n"]
+
+      it "accepts other elements" $ do
+        ("1. \"Module\"\n\n2. /emphasis/"
+                    ++ "\n\n3. @code@\n\n4. a@mono@b \n\n5.") `shouldParseTo`
+          DocOrderedList [
+              DocParagraph (" " <> DocModule "Module" <> "\n")
+            , DocParagraph (" " <> DocEmphasis "emphasis" <> "\n")
+            , DocCodeBlock "code"
+            , DocParagraph (" a" <> DocMonospaced "mono" <> "b \n")
+            , DocParagraph "\n"
+            ]
+
+    context "when parsing definition lists" $ do
+      it "parses a simple list" $ do
+        "[foo] bar\n\n[baz] quux" `shouldParseTo`
+          DocDefList [("foo", " bar\n"), ("baz", " quux\n")]
+
+      it "parses a list with unicode in it" $ do
+        "[灼眼] シャナ" `shouldParseTo`
+          DocDefList [("灼眼", " シャナ\n")]
+
+      it "parse other markup inside of it as usual" $ do
+        "[/foo/] bar" `shouldParseTo`
+          DocDefList [(DocEmphasis "foo", " bar\n")]
+
+      it "doesn't need a string to follow it" $ do
+        "[hello /world/]" `shouldParseTo`
+          DocDefList [("hello " <> DocEmphasis "world", "\n")]
+
+      it "takes input until the very last delimiter on the line" $ do
+        "[[world]] bar" `shouldParseTo`
+          DocDefList [("[world", "] bar\n")]
 
     context "when parsing an example" $ do
-      it "requires an example to be separated from a previous paragrap by an empty line" $ do
-        parseParas "foobar\n\n>>> fib 10\n55" `shouldBe`
-          Just (DocParagraph "foobar\n" <> DocExamples [Example "fib 10" ["55"]])
+      it ("requires an example to be separated"
+          ++ " from a previous paragraph by an empty line") $ do
+        "foobar\n\n>>> fib 10\n55" `shouldParseTo`
+          DocParagraph "foobar\n"
+                <> DocExamples [Example "fib 10" ["55"]]
 
         -- parse error
         parseParas "foobar\n>>> fib 10\n55" `shouldBe` Nothing
 
-      it "parses a result line that only contains <BLANKLINE> as an emptly line" $ do
-        parseParas ">>> putFooBar\nfoo\n<BLANKLINE>\nbar" `shouldBe`
-          Just (DocExamples [Example "putFooBar" ["foo","","bar"]])
+      it "parses a prompt with no example results" $ do
+        " >>> import Data.Char\n " `shouldParseTo`
+          DocExamples [ Example { exampleExpression = "import Data.Char"
+                                      , exampleResult = []
+                                      }
+                            ]
+
+      it "is able to parse example sections with unicode" $ do
+        " >>> 灼眼\n の\n >>> シャナ\n 封絶" `shouldParseTo`
+          DocExamples [ Example { exampleExpression = "灼眼"
+                                      , exampleResult = ["の"]
+                                      }
+                            , Example { exampleExpression = "シャナ"
+                                      , exampleResult = ["封絶"]
+                                      }
+                            ]
+
+      it ("parses a result line that only "
+          ++ "contains <BLANKLINE> as an empty line") $ do
+        ">>> putFooBar\nfoo\n<BLANKLINE>\nbar" `shouldParseTo`
+          DocExamples [Example "putFooBar" ["foo","","bar"]]
 
     context "when parsing a code block" $ do
-      it "requires a code blocks to be separated from a previous paragrap by an empty line" $ do
-        parseParas "foobar\n\n> some code" `shouldBe`
-          Just (DocParagraph "foobar\n" <> DocCodeBlock " some code\n")
+      it ("requires a code blocks to be "
+          ++ "separated from a previous paragraph by an empty line") $ do
+        "foobar\n\n> some code" `shouldParseTo`
+          DocParagraph "foobar\n" <> DocCodeBlock " some code\n"
 
         -- parse error
         parseParas "foobar\n> some code" `shouldBe` Nothing
 
+      it "consecutive birdtracks " $ do
+        ">test3\n>test4\n\n" `shouldParseTo` DocCodeBlock "test3\ntest4\n"
+
+      it "consecutive birdtracks with spaces " $ do
+        " > foo\n \n > bar\n \n" `shouldParseTo`
+          DocCodeBlock " foo\n" <> DocCodeBlock " bar\n"
+
+      it "code block + birdtracks" $ do
+        "@\ntest1\ntest2\n@\n\n>test3\n>test4\n\n" `shouldParseTo`
+          DocCodeBlock "\ntest1\ntest2\n" <> DocCodeBlock "test3\ntest4\n"
+
+      it "birdtracks + code block" $ do
+        ">test3\n>test4\n\n@\ntest1\ntest2\n@\n\n" `shouldParseTo`
+          DocCodeBlock "test3\ntest4\n" <> DocCodeBlock "\ntest1\ntest2\n"
+
+
+
+      it "can parse consecutive prompts with results" $ do
+        " >>> fib 5\n 5\n >>> fib 10\n 55" `shouldParseTo`
+          DocExamples [ Example { exampleExpression = "fib 5"
+                                      , exampleResult = ["5"]
+                                      }
+                            , Example { exampleExpression = "fib 10"
+                                      , exampleResult = ["55"]
+                                      }
+                            ]
 
     context "when parsing a URL" $ do
       it "parses a URL" $ do
-        parseParas "<http://example.com/>" `shouldBe`
-          Just (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n")
+        "<http://example.com/>" `shouldParseTo`
+          (DocParagraph $ hyperlink "http://example.com/" Nothing <> "\n")
 
       it "accepts an optional label" $ do
-        parseParas "<http://example.com/ some link>" `shouldBe`
-          Just (DocParagraph $ hyperlink "http://example.com/" (Just "some link") <> "\n")
+        "<http://example.com/ some link>" `shouldParseTo`
+          (DocParagraph $ hyperlink "http://example.com/" "some link" <> "\n")
+
+      it "consecutive URL and URL + label" $ do
+        (" \nA plain URL: <http://example.com/>\n\n A URL with a "
+                    ++ "label: <http://example.com/ some link>") `shouldParseTo`
+          DocParagraph (
+            "A plain URL: " <>
+              DocHyperlink (Hyperlink "http://example.com/" Nothing) <> "\n"
+          ) <>
+          DocParagraph (
+            "A URL with a label: " <>
+              DocHyperlink (Hyperlink "http://example.com/" "some link") <> "\n"
+          )
+
+      it "finishes URL parsing as soon as it sees >, even if it's escaped" $ do
+        "<http://examp\\>le.com" `shouldParseTo`
+          DocParagraph (
+            DocHyperlink (Hyperlink "http://examp\\" Nothing) <> "le.com\n"
+          )
+
+        "<http://exa\\>mp\\>le.com>" `shouldParseTo`
+          DocParagraph (
+            DocHyperlink (Hyperlink "http://exa\\" Nothing) <> "mp>le.com>\n"
+          )
+
+        -- Likewise in label
+        "<http://example.com f\\>oo>" `shouldParseTo`
+          DocParagraph (
+            DocHyperlink (Hyperlink "http://example.com" "f\\") <> "oo>\n"
+          )
+
+      it "parses inline URLs" $ do
+        (" Not yet working, see <http://trac.haskell.org"
+                    ++ "/haddock/ticket/223>\n , isEmptyChan") `shouldParseTo`
+          DocParagraph
+                ("Not yet working, see "
+                 <> ((DocHyperlink
+                      (Hyperlink { hyperlinkUrl = "http://trac.haskell.org"
+                                                  ++ "/haddock/ticket/223"
+                                 , hyperlinkLabel = Nothing
+                                 })) <> "\n , isEmptyChan\n"))
 
     context "when parsing properties" $ do
       it "can parse a single property" $ do
-        parseParas "prop> 23 == 23" `shouldBe` Just (DocProperty "23 == 23")
+        "prop> 23 == 23" `shouldParseTo` DocProperty "23 == 23"
 
       it "can parse multiple subsequent properties" $ do
-        parseParas $ unlines [
+        unlines [
               "prop> 23 == 23"
             , "prop> 42 == 42"
             ]
-        `shouldBe` Just (DocProperty "23 == 23" <> DocProperty "42 == 42")
+        `shouldParseTo`
+          DocProperty "23 == 23" <> DocProperty "42 == 42"
+
+      it "accepts unicode in properties" $ do
+        "prop> 灼眼のシャナ ≡ 愛" `shouldParseTo`
+          DocProperty "灼眼のシャナ ≡ 愛"
+
+      it "can deal with whitespace before and after the prop> prompt" $ do
+        "  prop>     xs == (reverse $ reverse xs)" `shouldParseTo`
+          DocProperty "xs == (reverse $ reverse xs)"
+
+    context "when escaping elements" $ do
+
+      it "escapes \\#\\#\\#" $ do
+        " We should be able to escape this: \\#\\#\\#" `shouldParseTo`
+          DocParagraph "We should be able to escape this: ###\n"
+
+      it "escapes forward slashes" $ do
+        " Existential \\/ Universal types" `shouldParseTo`
+          DocParagraph "Existential / Universal types\n"
+
+    context "when parsing pictures" $ do
+      it "parses a simple picture" $ do
+        "<<baz>>" `shouldParseTo`
+          DocParagraph ((DocPic "baz") <> "\n")
+
+      it "parses a picture with spaces" $ do
+        "<<b a z>>" `shouldParseTo`
+          DocParagraph ((DocPic "b a z") <> "\n")
+
+      it "parses a picture with unicode" $ do
+        "<<灼眼のシャナ>>" `shouldParseTo`
+          DocParagraph ((DocPic "灼眼のシャナ") <> "\n")
+
+      it "doesn't allow for escaping of the closing tags" $ do -- bug?
+        "<<ba\\>>z>>" `shouldParseTo`
+          (DocParagraph $ DocPic "ba\\" <> "z>>\n")
+
+    context "when parsing anchors" $ do
+      it "should parse a single word anchor" $ do
+        "#foo#" `shouldParseTo`
+          DocParagraph ((DocAName "foo") <> "\n")
+
+      it "should parse a multi word anchor" $ do
+        "#foo bar#" `shouldParseTo`
+          DocParagraph ((DocAName "foo bar") <> "\n")
+
+      it "should parse a unicode anchor" $ do
+        "#灼眼のシャナ#" `shouldParseTo`
+          DocParagraph (DocAName "灼眼のシャナ" <> "\n")
+
+    context "replicates parsing of weird strings" $ do
+      it "#f\\noo#" $ do
+        "#f\noo#" `shouldParseTo` DocParagraph "#f\noo#\n"
+
+      it "<b\\nar>" $ do
+        "<b\nar>" `shouldParseTo` DocParagraph "<b\nar>\n"
+
+      it "<<ba\\nz aar>>" $ do
+        "<<ba\nz aar>>" `shouldParseTo` DocParagraph "<<ba\nz aar>>\n"
+
+      it "[@q/uu/x@] h\\ney" $ do
+        "[@q/uu/x@] h\ney" `shouldParseTo`
+          DocDefList
+                [(DocMonospaced
+                  ((DocString "q")
+                   <> ((DocEmphasis (DocString "uu"))
+                       <> "x")), " h\ney\n")]
+
+      it "[qu\\nx] hey" $ do
+        parseParas "[qu\nx] hey" `shouldBe` Nothing
+
+      it "/qu\\nux/" $ do
+        "/qu\nux/" `shouldParseTo` DocParagraph "/qu\nux/\n"
+
+    context "when parsing strings with apostrophes" $ do
+      it "parses a word with an one of the delimiters in it as DocString" $ do
+        "don't" `shouldParseTo` DocParagraph "don't\n"
+
+      it "doesn't pass pairs of delimiters with spaces between them" $ do
+        "hel'lo w'orld" `shouldParseTo` DocParagraph "hel'lo w'orld\n"
+
+      it "don't use apostrophe's in the wrong place's" $ do
+        " don't use apostrophe's in the wrong place's" `shouldParseTo`
+          DocParagraph "don't use apostrophe's in the wrong place's\n"
+
   where
     hyperlink :: String -> Maybe String -> Doc RdrName
     hyperlink url = DocHyperlink . Hyperlink url