diff --git a/CHANGELOG.md b/CHANGELOG.md index 48138b0..a22cd5a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -120,6 +120,9 @@ * `sepEndBy` * `sepEndBy1` +* Added combinator `string'` which is the same as `string`, but + case-insensitive. + * Added comprehensive QuickCheck test suite. * Added benchmarks. diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs index 3ac865b..7f85850 100644 --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -121,6 +121,7 @@ module Text.Megaparsec , noneOf , satisfy , string + , string' -- * Error messages , Message (..) , messageString diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs index e611224..21921c4 100644 --- a/Text/Megaparsec/Char.hs +++ b/Text/Megaparsec/Char.hs @@ -41,7 +41,8 @@ module Text.Megaparsec.Char , oneOf , noneOf , satisfy - , string ) + , string + , string' ) where import Control.Applicative ((<|>)) @@ -276,4 +277,14 @@ satisfy f = token nextPos testChar -- > divOrMod = string "div" <|> string "mod" string :: Stream s m Char => String -> ParsecT s u m String -string = tokens updatePosString +string = tokens updatePosString (==) + +-- | The same as 'string', but case-insensitive. On success returns string +-- cased as argument of the function. +-- +-- >>> parseTest (string' "foobar") "foObAr" +-- "foobar" + +string' :: Stream s m Char => String -> ParsecT s u m String +string' = tokens updatePosString test + where test x y = toLower x == toLower y diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs index 9866a6b..eaaeb49 100644 --- a/Text/Megaparsec/Prim.hs +++ b/Text/Megaparsec/Prim.hs @@ -582,37 +582,38 @@ token nextpos test = ParsecT $ \(State input pos u) cok _ _ eerr -> do in seq newpos $ seq newstate $ cok x newstate mempty Nothing -> eerr $ unexpectedErr (showToken c) pos --- | The parser @tokens posFromTok@ parses list of tokens and returns +-- | The parser @tokens posFromTok test@ parses list of tokens and returns -- it. The resulting parser will use 'showToken' to pretty-print the --- collection of tokens. +-- collection of tokens. Supplied predicate @test@ is used to check equality +-- of given and parsed tokens. -- -- This can be used to example to write 'Text.Megaparsec.Char.string': -- --- > string = tokens updatePosString +-- > string = tokens updatePosString (==) tokens :: (Stream s m t, Eq t, ShowToken [t]) => (SourcePos -> [t] -> SourcePos) -- ^ Computes position of tokens. - -> [t] -- ^ List of tokens to parse + -> (t -> t -> Bool) -- ^ Predicate to check equality of tokens. + -> [t] -- ^ List of tokens to parse -> ParsecT s u m [t] {-# INLINE tokens #-} -tokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty -tokens nextposs tts = ParsecT $ \(State input pos u) cok cerr _ eerr -> +tokens _ _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty +tokens nextpos test tts = ParsecT $ \(State input pos u) cok cerr _ eerr -> let errExpect x = setErrorMessage (Expected $ showToken tts) (newErrorMessage (Unexpected x) pos) - walk [] _ rs = let pos' = nextposs pos tts + walk [] _ rs = let pos' = nextpos pos tts s' = State rs pos' u in cok tts s' mempty - walk (t:ts) i rs = do + walk (t:ts) is rs = do sr <- uncons rs - let errorCont = if i == 0 then eerr else cerr - what = bool (showToken $ take i tts) "end of input" (i == 0) + let errorCont = if null is then eerr else cerr + what = bool (showToken $ reverse is) "end of input" (null is) case sr of Nothing -> errorCont . errExpect $ what Just (x,xs) - | t == x -> walk ts (succ i) xs - | otherwise -> errorCont . errExpect . showToken $ - take i tts ++ [x] - in walk tts 0 input + | test t x -> walk ts (x:is) xs + | otherwise -> errorCont . errExpect . showToken $ reverse (x:is) + in walk tts [] input unexpectedErr :: String -> SourcePos -> ParseError unexpectedErr msg = newErrorMessage (Unexpected msg) diff --git a/tests/Char.hs b/tests/Char.hs index 8110d2b..0109b15 100644 --- a/tests/Char.hs +++ b/tests/Char.hs @@ -71,7 +71,8 @@ tests = testGroup "Character parsers" , testProperty "anyChar" prop_anyChar , testProperty "oneOf" prop_oneOf , testProperty "noneOf" prop_noneOf - , testProperty "string" prop_string ] + , testProperty "string" prop_string + , testProperty "string'" prop_string' ] instance Arbitrary GeneralCategory where arbitrary = elements @@ -110,7 +111,7 @@ prop_newline :: String -> Property prop_newline = checkChar newline (== '\n') (Just "newline") prop_crlf :: String -> Property -prop_crlf = checkString crlf "\r\n" "crlf newline" +prop_crlf = checkString crlf "\r\n" (==) "crlf newline" prop_eol :: String -> Property prop_eol s = checkParser eol r s @@ -211,4 +212,8 @@ prop_noneOf :: String -> String -> Property prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing prop_string :: String -> String -> Property -prop_string a = checkString (string a) a (showToken a) +prop_string a = checkString (string a) a (==) (showToken a) + +prop_string' :: String -> String -> Property +prop_string' a = checkString (string' a) a test (showToken a) + where test x y = toLower x == toLower y diff --git a/tests/Prim.hs b/tests/Prim.hs index efe3720..e1e892b 100644 --- a/tests/Prim.hs +++ b/tests/Prim.hs @@ -325,8 +325,8 @@ prop_token s = checkParser p r s | otherwise = posErr 0 s [uneCh h] prop_tokens :: String -> String -> Property -prop_tokens a = checkString p a (showToken a) - where p = tokens updatePosString a +prop_tokens a = checkString p a (==) (showToken a) + where p = tokens updatePosString (==) a -- Parser state combinators diff --git a/tests/Util.hs b/tests/Util.hs index d3553a2..3de06b2 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -89,18 +89,20 @@ checkChar p f l' s = checkParser p r s | not (f h) = posErr 0 s (uneCh h : l) | otherwise = posErr 1 s [uneCh (s !! 1), exEof] --- | @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 p a test label s@ runs parser @p@ on input @s@ and checks if +-- the result is equal to @a@ and also quality of error messages. @test@ is +-- used to compare tokens. @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' +checkString :: Parser String -> String -> (Char -> Char -> Bool) -> + String -> String -> Property +checkString p a' test l s' = checkParser p (w a' 0 s') s' where w [] _ [] = Right a' w [] i (s:_) = posErr i s' [uneCh s, exEof] w _ 0 [] = posErr 0 s' [uneEof, exSpec l] w _ i [] = posErr 0 s' [uneStr (take i s'), exSpec l] w (a:as) i (s:ss) - | a == s = w as i' ss + | test a s = w as i' ss | otherwise = posErr 0 s' [uneStr (take i' s'), exSpec l] where i' = succ i