CodePoint versions of oneOf and noneOf

CHANGELOG.md

@@ -8,6 +8,9 @@ Breaking changes:
 
 New features:
 
+- Added primitive parsers `oneOfCodePoints` and `noneOfCodePoints` - `CodePoint`
+  versions of `oneOf` and `noneOf` respectively. (#127 by @fsoikin)
+
 Bugfixes:
 
 Other improvements:

src/Text/Parsing/Parser/String.purs

@@ -25,19 +25,23 @@ module Text.Parsing.Parser.String
   , whiteSpace
   , skipSpaces
   , oneOf
+  , oneOfCodePoints
   , noneOf
+  , noneOfCodePoints
   , match
   ) where
 
 import Prelude hiding (between)
 
+import Control.Alt ((<|>))
+import Control.Lazy (defer)
 import Control.Monad.State (get, put)
 import Data.Array (notElem)
 import Data.Char (fromCharCode)
 import Data.CodePoint.Unicode (isSpace)
 import Data.Foldable (elem)
 import Data.Maybe (Maybe(..))
-import Data.String (CodePoint, Pattern(..), null, stripPrefix, uncons)
+import Data.String (CodePoint, Pattern(..), null, singleton, stripPrefix, uncons)
 import Data.String.CodeUnits as SCU
 import Data.Tuple (Tuple(..), fst)
 import Text.Parsing.Parser (ParseState(..), ParserT, fail)
@@ -121,6 +125,14 @@ oneOf ss = satisfy (flip elem ss) <?> ("one of " <> show ss)
 noneOf :: forall m. Monad m => Array Char -> ParserT String m Char
 noneOf ss = satisfy (flip notElem ss) <?> ("none of " <> show ss)
 
+-- | Match one of the Unicode characters in the array.
+oneOfCodePoints :: forall m. Monad m => Array CodePoint -> ParserT String m CodePoint
+oneOfCodePoints ss = satisfyCodePoint (flip elem ss) <|> defer \_ -> fail $ "Expected one of " <> show (singleton <$> ss)
+
+-- | Match any Unicode character not in the array.
+noneOfCodePoints :: forall m. Monad m => Array CodePoint -> ParserT String m CodePoint
+noneOfCodePoints ss = satisfyCodePoint (flip notElem ss) <|> defer \_ -> fail $ "Expected none of " <> show (singleton <$> ss)
+
 -- | Updates a `Position` by adding the columns and lines in `String`.
 updatePosString :: Position -> String -> Position
 updatePosString pos str = case uncons str of
@@ -154,4 +166,4 @@ match p = do
 -- | This will break at runtime if the definition of CodePoint ever changes
 -- | to something other than `newtype CodePoint = CodePoint Int`.
 unCodePoint :: CodePoint -> Int
-unCodePoint = unsafeCoerce
+unCodePoint = unsafeCoerce

test/Main.purs

@@ -5,6 +5,7 @@ import Prelude hiding (between, when)
 import Control.Alt ((<|>))
 import Control.Lazy (fix)
 import Data.Array (some)
+import Data.Array as Array
 import Data.Either (Either(..))
 import Data.List (List(..), fromFoldable, many)
 import Data.List.NonEmpty (cons, cons')
@@ -16,12 +17,12 @@ import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Console (logShow)
 import Test.Assert (assert')
-import Text.Parsing.Parser (ParseError(..), Parser, ParserT, parseErrorPosition, region, runParser)
+import Text.Parsing.Parser (ParseError(..), Parser, ParserT, parseErrorMessage, parseErrorPosition, region, runParser)
 import Text.Parsing.Parser.Combinators (between, chainl, endBy1, optionMaybe, sepBy1, try)
 import Text.Parsing.Parser.Expr (Assoc(..), Operator(..), buildExprParser)
 import Text.Parsing.Parser.Language (haskellDef, haskellStyle, javaStyle)
 import Text.Parsing.Parser.Pos (Position(..), initialPos)
-import Text.Parsing.Parser.String (anyChar, anyCodePoint, char, eof, satisfy, string, whiteSpace)
+import Text.Parsing.Parser.String (anyChar, anyCodePoint, char, eof, noneOfCodePoints, oneOfCodePoints, satisfy, string, whiteSpace)
 import Text.Parsing.Parser.Token (TokenParser, letter, makeTokenParser, match, token, when)
 
 parens :: forall m a. Monad m => ParserT String m a -> ParserT String m a
@@ -49,6 +50,14 @@ parseErrorTestPosition p input expected = case runParser input p of
     assert' ("expected: " <> show expected <> ", pos: " <> show pos) (expected == pos)
     logShow expected
 
+parseErrorTestMessage :: forall s a. Show a => Parser s a -> s -> String -> Effect Unit
+parseErrorTestMessage p input expected = case runParser input p of
+  Right x -> assert' ("ParseError expected '" <> expected <> "' but parsed " <> show x) false
+  Left err -> do
+    let msg = parseErrorMessage err
+    assert' ("expected: " <> expected <> ", message: " <> msg) (expected == msg)
+    logShow expected
+
 opTest :: Parser String String
 opTest = chainl (singleton <$> anyChar) (char '+' $> append) ""
 
@@ -465,6 +474,21 @@ main = do
     sixteenth <- string "𝅘𝅥𝅯" <|> (singleton <$> char 'x')
     pure $ [ SCP.singleton quarter, eighth, letterx, sixteenth ]
 
+  parseTest "🤔💯✅🤔💯" [ "🤔💯", "✅🤔💯" ] do
+    none <- Array.many $ noneOfCodePoints $ SCP.toCodePointArray "❓✅"
+    one <- Array.many $ oneOfCodePoints $ SCP.toCodePointArray "🤔💯✅"
+    pure $ SCP.fromCodePointArray <$> [ none, one ]
+
+  parseErrorTestMessage
+    (noneOfCodePoints $ SCP.toCodePointArray "❓✅")
+    "❓"
+    "Expected none of [\"❓\",\"✅\"]"
+
+  parseErrorTestMessage
+    (oneOfCodePoints $ SCP.toCodePointArray "❓✅")
+    "abc"
+    "Expected one of [\"❓\",\"✅\"]"
+
   parseTest "aa  bb" [ "aa", "  ", "bb" ] do
     aa <- SCU.fromCharArray <$> some letter
     w <- whiteSpace