finished tests for ‘Text.Megaparsec.Char’

tests/Char.hs

@@ -30,17 +30,13 @@
 module Char (tests) where
 
 import Data.Char
-import Data.List (findIndex, isPrefixOf)
+import Data.List (findIndex)
 
 import Test.Framework
 import Test.QuickCheck
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 
 import Text.Megaparsec.Char
-import Text.Megaparsec.Combinator
-import Text.Megaparsec.Error
-import Text.Megaparsec.Pos
-import Text.Megaparsec.Prim
 
 import Util
 
@@ -66,10 +62,10 @@ tests = testGroup "Character parsers"
         , testProperty "string" prop_string ]
 
 prop_oneOf :: String -> String -> Property
-prop_oneOf a = singleChar (oneOf a) (`elem` a) Nothing
+prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing
 
 prop_noneOf :: String -> String -> Property
-prop_noneOf a = singleChar (noneOf a) (`notElem` a) Nothing
+prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing
 
 prop_spaces :: String -> Property
 prop_spaces s = checkParser spaces r s
@@ -84,59 +80,48 @@ prop_spaces s = checkParser spaces r s
                 Nothing -> Right ()
 
 prop_space :: String -> Property
-prop_space = singleChar space isSpace (Just "white space")
+prop_space = checkChar space isSpace (Just "white space")
 
 prop_newline :: String -> Property
-prop_newline = singleChar newline (== '\n') (Just "newline")
+prop_newline = checkChar newline (== '\n') (Just "newline")
 
 prop_crlf :: String -> Property
-prop_crlf s = property True -- TODO
+prop_crlf = checkString crlf "\r\n" "crlf newline"
 
 prop_eol :: String -> Property
-prop_eol s = property True -- TODO
+prop_eol s = checkParser eol r s
+  where r | not (null s) && head s == '\r' = simpleParse crlf s
+          | otherwise                      = simpleParse eol s
 
 prop_tab :: String -> Property
-prop_tab = singleChar tab (== '\t') (Just "tab")
+prop_tab = checkChar tab (== '\t') (Just "tab")
 
 prop_upper :: String -> Property
-prop_upper = singleChar upper isUpper (Just "uppercase letter")
+prop_upper = checkChar upper isUpper (Just "uppercase letter")
 
 prop_lower :: String -> Property
-prop_lower = singleChar lower isLower (Just "lowercase letter")
+prop_lower = checkChar lower isLower (Just "lowercase letter")
 
 prop_alphaNum :: String -> Property
-prop_alphaNum = singleChar alphaNum isAlphaNum (Just "letter or digit")
+prop_alphaNum = checkChar alphaNum isAlphaNum (Just "letter or digit")
 
 prop_letter :: String -> Property
-prop_letter = singleChar letter isAlpha (Just "letter")
+prop_letter = checkChar letter isAlpha (Just "letter")
 
 prop_digit :: String -> Property
-prop_digit = singleChar digit isDigit (Just "digit")
+prop_digit = checkChar digit isDigit (Just "digit")
 
 prop_hexDigit :: String -> Property
-prop_hexDigit = singleChar hexDigit isHexDigit (Just "hexadecimal digit")
+prop_hexDigit = checkChar hexDigit isHexDigit (Just "hexadecimal digit")
 
 prop_octDigit :: String -> Property
-prop_octDigit = singleChar octDigit isOctDigit (Just "octal digit")
+prop_octDigit = checkChar octDigit isOctDigit (Just "octal digit")
 
 prop_char :: Char -> String -> Property
-prop_char c = singleChar (char c) (== c) (Just $ showToken c)
+prop_char c = checkChar (char c) (== c) (Just $ showToken c)
 
 prop_anyChar :: String -> Property
-prop_anyChar = singleChar anyChar (const True) (Just "character")
+prop_anyChar = checkChar anyChar (const True) (Just "character")
-
--- FIXME: In general, currently I don't like error messages that ‘string’
--- produces. It tells me about first mismatching letter, but also presents
--- the whole expected word:
---
--- λ> parseTest (string "re" <* eof) "ri"
--- parse error at line 1, column 1:
--- unexpected "i"
--- expecting "re"
---
--- is it the best error message we can get here?
 
 prop_string :: String -> String -> Property
-prop_string a s = property True
+prop_string a = checkString (string a) a (showToken a)
--- prop_string a s = checkParser (string a) r s
---     where r | a == s = Right s

tests/Util.hs

@@ -29,7 +29,9 @@
 
 module Util
     ( checkParser
-    , singleChar
+    , simpleParse
+    , checkChar
+    , checkString
     , posErr
     , suneStr
     , suneCh
@@ -58,16 +60,24 @@ import Text.Megaparsec.String
 
 checkParser :: (Eq a, Show a) =>
                Parser a -> Either ParseError a -> String -> Property
-checkParser p r s = parse (p <* eof) "" s === r
+checkParser p r s = simpleParse p s === r
 
--- | @singleChar p test label s@ runs parser @p@ on input @s@ and checks if
+-- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding
+-- result of type @Either ParseError a@, where @a@ is type of parsed
+-- value. This parser tries to parser end of file too and name of input file
+-- is always empty string.
+
+simpleParse :: Parser a -> String -> Either ParseError a
+simpleParse p = parse (p <* eof) ""
+
+-- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if
 -- the parser correctly parses single character that satisfies @test@. The
 -- character may be labelled, in this case @label@ is used to check quality
 -- of error messages.
 
-singleChar :: Parser Char -> (Char -> Bool) ->
+checkChar :: Parser Char -> (Char -> Bool) ->
               Maybe String -> String -> Property
-singleChar p f l' s = checkParser p r s
+checkChar p f l' s = checkParser p r s
     where h = head s
           l = exSpec <$> maybeToList l'
           r | null s = posErr 0 s (suneStr "" : l)
@@ -75,6 +85,21 @@ singleChar p f l' s = checkParser p r s
             | not (f h) = posErr 0 s (suneCh h : l)
             | otherwise = posErr 1 s [uneCh (s !! 1), exStr ""]
 
+-- | @checkString p a label s@ runs parser @p@ on input @s@ and checks if
+-- the result is equal to @a@ and also quality of error messages. @label@ is
+-- used as expected representation of parser's result in error messages.
+
+checkString :: Parser String -> String -> String -> String -> Property
+checkString p a' l s' = checkParser p (w a' 0 s') s'
+    where w [] _ []    = Right a'
+          w [] i (s:_) = posErr i s' [uneCh s, exStr ""]
+          w _  0 []    = posErr 0 s' [suneStr "", exSpec l]
+          w _  i []    = posErr 0 s' [suneStr (take i s'), exSpec l]
+          w (a:as) i (s:ss)
+            | a == s    = w as i' ss
+            | otherwise = posErr 0 s' [suneStr (take i' s'), exSpec l]
+              where i'  = succ i
+
 -- | @posErr pos s ms@ is an easy way to model result of parser that
 -- fails. @pos@ is how many tokens (characters) has been consumed before
 -- failure. @s@ is input of the parser. @ms@ is a list, collection of
@@ -123,7 +148,9 @@ exCh :: Char -> Message
 exCh s = Expect $ showToken s
 
 -- | @exSpec s@ returns message created with 'Expect' constructor that tells
--- the system that string @s@ is expected.
+-- the system that string @s@ is expected. This is different from 'exStr' in
+-- that it doesn't use 'showToken' but rather pass its argument unaltered
+-- allowing for “special” labels.
 
 exSpec :: String -> Message
 exSpec = Expect