added new parser ‘string'’

This is like ‘string’, but is case-insensitive.

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.

Text/Megaparsec.hs

@@ -121,6 +121,7 @@ module Text.Megaparsec
   , noneOf
   , satisfy
   , string
+  , string'
     -- * Error messages
   , Message (..)
   , messageString

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

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)

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

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
 

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