diff --git a/bower.json b/bower.json index a98673c..5db248e 100644 --- a/bower.json +++ b/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", diff --git a/psc-package.json b/psc-package.json index ef8e887..71849ab 100644 --- a/psc-package.json +++ b/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", diff --git a/src/Text/Parsing/Parser.purs b/src/Text/Parsing/Parser.purs index 55204ad..335a725 100644 --- a/src/Text/Parsing/Parser.purs +++ b/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 diff --git a/src/Text/Parsing/Parser/Combinators.purs b/src/Text/Parsing/Parser/Combinators.purs index df2daa1..38e73dc 100644 --- a/src/Text/Parsing/Parser/Combinators.purs +++ b/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) diff --git a/test/Main.purs b/test/Main.purs index 8bd3742..9e31498 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -6,7 +6,8 @@ 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(..)) @@ -14,7 +15,7 @@ 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 \ No newline at end of file