Add a regex combinator

src/Text/Parsing/StringParser/String.purs

@@ -15,17 +15,20 @@ module Text.Parsing.StringParser.String
   , upperCaseChar
   , anyLetter
   , alphaNum
+  , regex
   ) where
 
 import Prelude
 
 import Control.Alt ((<|>))
-import Data.Array ((..))
+import Data.Array ((..), uncons)
 import Data.Char (toCharCode)
 import Data.Either (Either(..))
 import Data.Foldable (class Foldable, foldMap, elem, notElem)
-import Data.Maybe (Maybe(..))
-import Data.String (Pattern(..), charAt, length, indexOf', singleton)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String (Pattern(..), charAt, drop, length, indexOf', singleton, stripPrefix)
+import Data.String.Regex as Regex
+import Data.String.Regex.Flags (noFlags)
 import Text.Parsing.StringParser (Parser(..), ParseError(..), try, fail)
 import Text.Parsing.StringParser.Combinators (many, (<?>))
 
@@ -111,3 +114,31 @@ anyLetter = lowerCaseChar <|> upperCaseChar <?> "Expected a letter"
 -- | Match a letter or a number.
 alphaNum :: Parser Char
 alphaNum = anyLetter <|> anyDigit <?> "Expected a letter or a number"
+
+-- | match the regular expression
+regex :: String -> Parser String
+regex pat =
+  case Regex.regex pattern noFlags of
+    Left _ ->
+      fail $ "Text.Parsing.StringParser.String.regex': illegal regex " <> pat
+    Right r ->
+      matchRegex r
+  where
+    -- ensure the pattern only matches the current position in the parse
+    pattern =
+      case stripPrefix (Pattern "^") pat of
+        Nothing ->
+          "^" <> pat
+        _ ->
+          pat
+    matchRegex :: Regex.Regex -> Parser String
+    matchRegex r =
+      Parser \{ str, pos } ->
+        let
+          remainder = drop pos str
+        in
+          case uncons $ fromMaybe [] $ Regex.match r remainder of
+            Just { head: Just matched, tail: _ }  ->
+              Right { result: matched, suffix: { str, pos: pos + length matched } }
+            _ ->
+              Left { pos, error: ParseError "no match" }

test/Main.purs

@@ -15,7 +15,7 @@ import Test.Assert (assert', ASSERT, assert)
 import Text.Parsing.StringParser (Parser, runParser, try)
 import Text.Parsing.StringParser.Combinators (many1, endBy1, sepBy1, optionMaybe, many, chainl, fix, between)
 import Text.Parsing.StringParser.Expr (Assoc(..), Operator(..), buildExprParser)
-import Text.Parsing.StringParser.String (anyDigit, eof, string, anyChar)
+import Text.Parsing.StringParser.String (anyDigit, eof, string, anyChar, regex)
 
 parens :: forall a. Parser a -> Parser a
 parens = between (string "(") (string ")")
@@ -48,6 +48,7 @@ exprTest = buildExprParser [ [Infix (string "/" >>= \_ -> pure div) AssocRight]
                            ] digit
 
 tryTest :: Parser String
+            -- reduce the possible array of matches to 0 or 1 elements to aid Array pattern matching
 tryTest = try ((<>) <$> string "aa" <*> string "bb") <|>
           (<>) <$> string "aa" <*> string "cc"
 
@@ -84,3 +85,4 @@ main = do
   assert' "tryTest "$ canParse tryTest "aacc"
   assert $ expectResult ('0':'1':'2':'3':'4':Nil) (many1 anyDigit) "01234/"
   assert $ expectResult ('5':'6':'7':'8':'9':Nil) (many1 anyDigit) "56789:"
+  assert $ expectResult "aaaa" (regex "a+") "aaaab"