Compactableand Filterable instances

bower.json

@@ -22,6 +22,7 @@
   "dependencies": {
     "purescript-arrays": "^5.0.0",
     "purescript-either": "^4.0.0",
+    "purescript-filterable": "^3.0.2",
     "purescript-foldable-traversable": "^4.0.0",
     "purescript-identity": "^4.0.0",
     "purescript-integers": "^4.0.0",

psc-package.json

@@ -1,10 +1,11 @@
 {
   "name": "purescript-parsing",
-  "set": "psc-0.12.0",
+  "set": "psc-0.13.5",
   "source": "https://github.com/purescript/package-sets.git",
   "depends": [
     "arrays",
     "either",
+    "filterable",
     "foldable-traversable",
     "identity",
     "integers",

src/Text/Parsing/Parser.purs

@@ -9,7 +9,9 @@ module Text.Parsing.Parser
   , runParserT
   , hoistParserT
   , mapParserT
+  , setConsumed
   , consume
+  , unconsume
   , position
   , fail
   , failWithPosition
@@ -23,11 +25,14 @@ import Control.Lazy (defer, class Lazy)
 import Control.Monad.Error.Class (class MonadThrow, throwError)
 import Control.Monad.Except (class MonadError, ExceptT(..), runExceptT, mapExceptT)
 import Control.Monad.Rec.Class (class MonadRec)
-import Control.Monad.State (class MonadState, StateT(..), evalStateT, gets, mapStateT, modify_, runStateT)
+import Control.Monad.State (class MonadState, StateT(..), evalStateT, get, gets, put, mapStateT, modify_, runStateT)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Control.MonadPlus (class Alternative, class MonadZero, class MonadPlus, class Plus)
+import Data.Compactable (class Compactable)
 import Data.Either (Either(..))
+import Data.Filterable (class Filterable)
 import Data.Identity (Identity)
+import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype, unwrap, over)
 import Data.Tuple (Tuple(..))
 import Text.Parsing.Parser.Pos (Position, initialPos)
@@ -120,10 +125,77 @@ instance monadPlusParserT :: Monad m => MonadPlus (ParserT s m)
 instance monadTransParserT :: MonadTrans (ParserT s) where
   lift = ParserT <<< lift <<< lift
 
+instance compactableParserT :: Monad m => Compactable (ParserT s m) where
+  compact p1 = do
+    state <- get
+    p1 >>= case _ of
+      Just r -> pure r
+      Nothing -> put state *> fail "Parse returned Nothing"
+  separate p1 =
+    { left: do
+        state <- get
+        p1 >>= case _ of
+          Left r -> pure r
+          Right _ -> put state *> fail "Parse returned Right"
+    , right: do
+        state <- get
+        p1 >>= case _ of
+          Left _ -> put state *> fail "Parse returned Left"
+          Right r -> pure r
+    }
+
+instance filterableParserT :: Monad m => Filterable (ParserT s m) where
+  partitionMap pred p1 =
+    { left: do
+        state <- get
+        p1 <#> pred >>= case _ of
+          Left r -> pure r
+          Right _ -> put state *> fail "Predicate returned Right"
+    , right: do
+        state <- get
+        p1 <#> pred >>= case _ of
+          Left _ -> put state *> fail "Predicate returned Left"
+          Right r -> pure r
+    }
+  partition pred p1 =
+    { yes: do
+        state <- get
+        r <- p1
+        case pred r of
+          true -> pure r
+          false -> put state *> fail "Result did not satisfy predicate"
+    , no: do
+        state <- get
+        r <- p1
+        case pred r of
+          true -> put state *> fail "Result unexpectedly satisfied predicate"
+          false -> pure r
+    }
+  filterMap pred p1 = do
+    state <- get
+    p1 <#> pred >>= case _ of
+      Just r -> pure r
+      Nothing -> put state *> fail "Predicate returned Nothing"
+  filter pred p1 = do
+    state <- get
+    r <- p1
+    case pred r of
+      true -> pure r
+      false -> put state *> fail "Result did not satisfy predicate"
+
+
+-- | Set or unset the consumed flag.
+setConsumed :: forall s m. Monad m => Boolean -> ParserT s m Unit
+setConsumed bool = modify_ \(ParseState input pos _) ->
+  ParseState input pos bool
+
 -- | Set the consumed flag.
 consume :: forall s m. Monad m => ParserT s m Unit
-consume = modify_ \(ParseState input pos _) ->
-  ParseState input pos true
+consume = setConsumed true
+
+-- | Unset the consumed flag.
+unconsume :: forall s m. Monad m => ParserT s m Unit
+unconsume = setConsumed false
 
 -- | Returns the current position in the stream.
 position :: forall s m. Monad m => ParserT s m Position

src/Text/Parsing/Parser/Combinators.purs

@@ -28,6 +28,7 @@ import Control.Monad.Except (runExceptT, ExceptT(..))
 import Control.Monad.State (StateT(..), runStateT)
 import Control.Plus (empty, (<|>))
 import Data.Either (Either(..))
+import Data.Filterable (filterMap, partitionMap)
 import Data.Foldable (class Foldable, foldl)
 import Data.List (List(..), (:), many, some, singleton)
 import Data.Maybe (Maybe(..))
@@ -198,3 +199,25 @@ many1Till p end = do
   x <- p
   xs <- manyTill p end
   pure (x:xs)
+
+-- | Parse a phrase, and if it succeeds, run the mapping function over it. If
+-- | the provided parser fails, it will fail normally. If the mapping function
+-- | returns Nothing, the parser will fail with the provided error message.
+filterMapWithError
+  :: forall s a m b
+   . Monad m
+  => (a -> Maybe b) -> String -> ParserT s m a -> ParserT s m b
+filterMapWithError mapper error p =
+  lookAhead p >>= do pure >>> filterMap mapper >>> (_ <|> fail error)
+
+-- | Same as `filterMapWithError`, but instead of providing a string to error
+-- | with, the mapper should return an Either, which is a Right containing the
+-- | new result, or a Left containing the error message.
+filterMapEither
+  :: forall s a m b
+   . Monad m
+  => (a -> Either String b) -> ParserT s m a -> ParserT s m b
+filterMapEither mapper p = lookAhead p >>= do
+  pure
+    >>> partitionMap mapper
+    >>> \{left, right} -> right <|> (left >>= fail)

test/Main.purs

@@ -6,15 +6,16 @@ import Control.Alt ((<|>))
 import Control.Lazy (fix)
 import Data.Array (some)
 import Data.Either (Either(..))
-import Data.List (List(..), fromFoldable, many)
+import Data.Filterable (filter, filterMap, compact, separate, partition, partitionMap)
+import Data.List (List(..), fromFoldable, many, tail, (:))
 import Data.Maybe (Maybe(..))
 import Data.String.CodeUnits (fromCharArray, singleton)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Console (logShow)
 import Test.Assert (assert')
 import Text.Parsing.Parser (Parser, ParserT, runParser, parseErrorPosition)
-import Text.Parsing.Parser.Combinators (endBy1, sepBy1, optionMaybe, try, chainl, between)
+import Text.Parsing.Parser.Combinators (endBy1, sepBy1, sepBy, optionMaybe, try, chainl, between, filterMapWithError, filterMapEither)
 import Text.Parsing.Parser.Expr (Assoc(..), Operator(..), buildExprParser)
 import Text.Parsing.Parser.Language (javaStyle, haskellStyle, haskellDef)
 import Text.Parsing.Parser.Pos (Position(..), initialPos)
@@ -412,6 +413,54 @@ javaStyleTest = do
         "hello {- comment\n -} foo"
         (mkPos 7)
 
+filterableTest :: TestM
+filterableTest = do
+  -- filter does nothing when the predicate returns true
+  parseTest "6" 6 (filter (_ /= 5) digit)
+
+  -- filter acts as if the parser failed when predicate returns false
+  parseErrorTestPosition (filter (_ /= 6) digit) "6" (mkPos 1)
+
+  -- if a result is "filtered away", `alt` will try the next parser
+  parseTest "6" 6
+    $ filter (_ /= 6) digit <|> filter (_ /= 7) digit
+
+  -- using filterMap to elegantly apply a function that returns maybe
+  parseTest "1,2,3,4" (2 : 3 : 4 : Nil)
+    $ filterMap tail (digit `sepBy` string ",")
+
+-- `filterMap f` should be the same as `compact <<< map f`
+  parseTest "1,2,3,4" (2 : 3 : 4 : Nil)
+    $ (compact <<< map tail) (digit `sepBy` string ",")
+
+  -- same as above, throwing an error in the parser if the filterMap fails
+  (\p -> parseErrorTestPosition p "" (mkPos 1))
+    $ filterMap tail (digit `sepBy` string ",")
+
+  parseTest "1" 2
+    $ (_.right <<< separate) (digit $> Right 2)
+
+  parseTest "1" 3
+    $ (_.left <<< partitionMap (\n -> Left $ n + 2)) digit
+
+  -- when run after another parser with *>, correct error position is given
+  (\p -> parseErrorTestPosition p "12" (mkPos 2))
+    $ digit *> (_.yes <<< partition (_ == 3)) digit
+
+  -- filterMapWithError using Just as the mapper will act just like the original parser
+  parseTest "6" 6
+    $ filterMapWithError Just "shouldn't fail" digit
+
+  -- filterMapEither using Right as the mapper will act just like the original parser
+  parseTest "6" 6
+    $ filterMapEither Right digit
+
+  -- when run after another parser with *>, correct error position is given
+  (\p -> parseErrorTestPosition p "12" (mkPos 2))
+    $ digit *> filterMapEither
+                 (\n -> if n == 2 then Left "error" else Right n)
+                 digit
+
 main :: Effect Unit
 main = do
 
@@ -493,3 +542,5 @@ main = do
 
   haskellStyleTest
   javaStyleTest
+
+  filterableTest