diff --git a/LICENSE b/LICENSE index 7170681..854cdaa 100644 --- a/LICENSE +++ b/LICENSE @@ -1,23 +1,24 @@ -The MIT License (MIT) - -Copyright (c) 2014 PureScript - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +Copyright 2014-2016 PureScript + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +This software is provided by the copyright holders "as is" and any express or +implied warranties, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose are disclaimed. In no +event shall the copyright holders be liable for any direct, indirect, +incidental, special, exemplary, or consequential damages (including, but not +limited to, procurement of substitute goods or services; loss of use, data, +or profits; or business interruption) however caused and on any theory of +liability, whether in contract, strict liability, or tort (including +negligence or otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. ------------------------------------------------------------------------------- diff --git a/bower.json b/bower.json index 0dfbfdf..0f6b556 100644 --- a/bower.json +++ b/bower.json @@ -5,7 +5,7 @@ "keywords": [ "purescript" ], - "license": "MIT", + "license": "BSD3", "repository": { "type": "git", "url": "git://github.com/purescript-contrib/purescript-parsing.git" @@ -20,19 +20,19 @@ "package.json" ], "dependencies": { - "purescript-arrays": "^1.0.0", - "purescript-either": "^1.0.0", - "purescript-foldable-traversable": "^1.0.0", - "purescript-identity": "^1.0.0", - "purescript-integers": "^1.0.0", - "purescript-lists": "^1.0.0", - "purescript-maybe": "^1.0.0", - "purescript-strings": "^1.0.0", - "purescript-transformers": "^1.0.0", - "purescript-unicode": "^1.0.0" + "purescript-arrays": "^3.0.0", + "purescript-either": "^2.0.0", + "purescript-foldable-traversable": "^2.0.0", + "purescript-identity": "^2.0.0", + "purescript-integers": "^2.0.0", + "purescript-lists": "^2.0.0", + "purescript-maybe": "^2.0.0", + "purescript-strings": "^2.0.0", + "purescript-transformers": "^2.0.0", + "purescript-unicode": "^2.0.0" }, "devDependencies": { - "purescript-assert": "^1.0.0", - "purescript-console": "^1.0.0" + "purescript-assert": "^2.0.0", + "purescript-console": "^2.0.0" } } diff --git a/src/Text/Parsing/Parser.purs b/src/Text/Parsing/Parser.purs index 82fb519..cd5f1df 100644 --- a/src/Text/Parsing/Parser.purs +++ b/src/Text/Parsing/Parser.purs @@ -1,115 +1,107 @@ -module Text.Parsing.Parser where +module Text.Parsing.Parser + ( ParseError + , parseErrorMessage + , parseErrorPosition + , ParseState(..) + , ParserT(..) + , Parser + , runParser + , consume + , fail + ) where import Prelude - -import Control.Lazy (class Lazy) -import Control.Monad.State.Class (class MonadState) -import Control.Monad.Trans (class MonadTrans) -import Control.MonadPlus (class MonadPlus, class MonadZero, class Alternative) -import Control.Plus (class Plus, class Alt) +import Control.Alt (class Alt) +import Control.Lazy (defer, class Lazy) +import Control.Monad.Except (class MonadError, ExceptT(..), throwError, runExceptT) +import Control.Monad.Rec.Class (class MonadRec) +import Control.Monad.State (runStateT, class MonadState, StateT(..), gets, evalStateT, modify) +import Control.Monad.Trans.Class (lift, class MonadTrans) +import Control.MonadPlus (class Alternative, class MonadZero, class MonadPlus, class Plus) import Data.Either (Either(..)) -import Data.Identity (Identity, runIdentity) +import Data.Identity (Identity) +import Data.Newtype (class Newtype, unwrap) import Data.Tuple (Tuple(..)) import Text.Parsing.Parser.Pos (Position, initialPos) -- | A parsing error, consisting of a message and position information. -data ParseError = ParseError - { message :: String - , position :: Position - } +data ParseError = ParseError String Position + +parseErrorMessage :: ParseError -> String +parseErrorMessage (ParseError msg _) = msg + +parseErrorPosition :: ParseError -> Position +parseErrorPosition (ParseError _ pos) = pos instance showParseError :: Show ParseError where - show (ParseError msg) = "ParseError { message: " <> msg.message <> ", position: " <> show msg.position <> " }" + show (ParseError msg pos) = + "(ParseError " <> show msg <> show pos <> ")" -instance eqParseError :: Eq ParseError where - eq (ParseError {message : m1, position : p1}) (ParseError {message : m2, position : p2}) = m1 == m2 && p1 == p2 +derive instance eqParseError :: Eq ParseError +derive instance ordParseError :: Ord ParseError --- | `PState` contains the remaining input and current position. -data PState s = PState - { input :: s - , position :: Position - } +-- | Contains the remaining input and current position. +data ParseState s = ParseState s Position Boolean -- | The Parser monad transformer. -- | --- | The first type argument is the stream type. Typically, this is either `String`, or some sort of token stream. -newtype ParserT s m a = ParserT (PState s -> m { input :: s, result :: Either ParseError a, consumed :: Boolean, position :: Position }) +-- | The first type argument is the stream type. Typically, this is either `String`, +-- | or some sort of token stream. +newtype ParserT s m a = ParserT (ExceptT ParseError (StateT (ParseState s) m) a) --- | Apply a parser by providing an initial state. -unParserT :: forall m s a. ParserT s m a -> PState s -> m { input :: s, result :: Either ParseError a, consumed :: Boolean, position :: Position } -unParserT (ParserT p) = p +derive instance newtypeParserT :: Newtype (ParserT s m a) _ -- | Apply a parser, keeping only the parsed result. -runParserT :: forall m s a. Monad m => PState s -> ParserT s m a -> m (Either ParseError a) -runParserT s p = do - o <- unParserT p s - pure o.result +runParserT :: forall m s a. Monad m => s -> ParserT s m a -> m (Either ParseError a) +runParserT s p = evalStateT (runExceptT (unwrap p)) initialState where + initialState = ParseState s initialPos false -- | The `Parser` monad is a synonym for the parser monad transformer applied to the `Identity` monad. type Parser s a = ParserT s Identity a -- | Apply a parser, keeping only the parsed result. runParser :: forall s a. s -> Parser s a -> Either ParseError a -runParser s = runIdentity <<< runParserT (PState { input: s, position: initialPos }) +runParser s = unwrap <<< runParserT s -instance functorParserT :: (Functor m) => Functor (ParserT s m) where - map f p = ParserT $ \s -> f' <$> unParserT p s - where - f' o = { input: o.input, result: f <$> o.result, consumed: o.consumed, position: o.position } - -instance applyParserT :: Monad m => Apply (ParserT s m) where - apply = ap +instance lazyParserT :: Lazy (ParserT s m a) where + defer f = ParserT (ExceptT (defer (runExceptT <<< unwrap <<< f))) -instance applicativeParserT :: Monad m => Applicative (ParserT s m) where - pure a = ParserT $ \(PState { input: s, position: pos }) -> pure { input: s, result: Right a, consumed: false, position: pos } +derive newtype instance functorParserT :: Functor m => Functor (ParserT s m) +derive newtype instance applyParserT :: Monad m => Apply (ParserT s m) +derive newtype instance applicativeParserT :: Monad m => Applicative (ParserT s m) +derive newtype instance bindParserT :: Monad m => Bind (ParserT s m) +derive newtype instance monadParserT :: Monad m => Monad (ParserT s m) +derive newtype instance monadRecParserT :: MonadRec m => MonadRec (ParserT s m) +derive newtype instance monadStateParserT :: Monad m => MonadState (ParseState s) (ParserT s m) +derive newtype instance monadErrorParserT :: Monad m => MonadError ParseError (ParserT s m) instance altParserT :: Monad m => Alt (ParserT s m) where - alt p1 p2 = ParserT $ \s -> unParserT p1 s >>= \o -> - case o.result of - Left _ | not o.consumed -> unParserT p2 s - _ -> pure o + alt p1 p2 = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState i p _)) -> do + Tuple e s'@(ParseState i' p' c') <- runStateT (runExceptT (unwrap p1)) (ParseState i p false) + case e of + Left err + | not c' -> runStateT (runExceptT (unwrap p2)) s + _ -> pure (Tuple e s') instance plusParserT :: Monad m => Plus (ParserT s m) where empty = fail "No alternative" instance alternativeParserT :: Monad m => Alternative (ParserT s m) -instance bindParserT :: Monad m => Bind (ParserT s m) where - bind p f = ParserT $ \s -> unParserT p s >>= \o -> - case o.result of - Left err -> pure { input: o.input, result: Left err, consumed: o.consumed, position: o.position } - Right a -> updateConsumedFlag o.consumed <$> unParserT (f a) (PState { input: o.input, position: o.position }) - where - updateConsumedFlag c o = { input: o.input, consumed: c || o.consumed, result: o.result, position: o.position } - -instance monadParserT :: Monad m => Monad (ParserT s m) - instance monadZeroParserT :: Monad m => MonadZero (ParserT s m) instance monadPlusParserT :: Monad m => MonadPlus (ParserT s m) instance monadTransParserT :: MonadTrans (ParserT s) where - lift m = ParserT $ \(PState { input: s, position: pos }) -> (\a -> { input: s, consumed: false, result: Right a, position: pos }) <$> m - -instance monadStateParserT :: Monad m => MonadState s (ParserT s m) where - state f = ParserT $ \(PState { input: s, position: pos }) -> - pure $ case f s of - Tuple a s' -> { input: s', consumed: false, result: Right a, position: pos } - -instance lazyParserT :: Lazy (ParserT s m a) where - defer f = ParserT $ \s -> unParserT (f unit) s + lift = ParserT <<< lift <<< lift -- | Set the consumed flag. consume :: forall s m. Monad m => ParserT s m Unit -consume = ParserT $ \(PState { input: s, position: pos }) -> pure { consumed: true, input: s, result: Right unit, position: pos } +consume = modify \(ParseState input position _) -> + ParseState input position true -- | Fail with a message. fail :: forall m s a. Monad m => String -> ParserT s m a -fail message = ParserT $ \(PState { input: s, position: pos }) -> pure $ parseFailed s pos message - --- | Creates a failed parser state for the remaining input `s` and current position --- | with an error message. --- | --- | Most of the time, `fail` should be used instead. -parseFailed :: forall s a. s -> Position -> String -> { input :: s, result :: Either ParseError a, consumed :: Boolean, position :: Position } -parseFailed s pos message = { input: s, consumed: false, result: Left (ParseError { message: message, position: pos }), position: pos } +fail message = do + position <- gets \(ParseState _ pos _) -> pos + throwError (ParseError message position) diff --git a/src/Text/Parsing/Parser/Combinators.purs b/src/Text/Parsing/Parser/Combinators.purs index a5b388f..12422b6 100644 --- a/src/Text/Parsing/Parser/Combinators.purs +++ b/src/Text/Parsing/Parser/Combinators.purs @@ -1,6 +1,7 @@ -- | Combinators for creating parsers. -- | --- | ### Notes: +-- | ### Notes +-- | -- | A few of the known combinators from Parsec are missing in this module. That -- | is because they have already been defined in other libraries. -- | @@ -16,19 +17,20 @@ -- | ```purescript -- | Text.Parsec.many (char 'x') <=> fromCharArray <$> Data.Array.many (char 'x') -- | ``` --- | --- | === module Text.Parsing.Parser.Combinators where -import Prelude (class Functor, class Monad, Unit, ($), (*>), (<>), (<$>), bind, flip, pure, unit) - +import Prelude +import Control.Monad.Except (runExceptT, ExceptT(..)) +import Control.Monad.State (StateT(..), runStateT) import Control.Plus (empty, (<|>)) import Data.Either (Either(..)) import Data.Foldable (class Foldable, foldl) import Data.List (List(..), (:), many, some, singleton) import Data.Maybe (Maybe(..)) -import Text.Parsing.Parser (PState(..), ParserT(..), fail, unParserT) +import Data.Newtype (unwrap) +import Data.Tuple (Tuple(..)) +import Text.Parsing.Parser (ParseState(..), ParserT(..), fail) -- | Provide an error message in the case of failure. withErrorMessage :: forall m s a. Monad m => ParserT s m a -> String -> ParserT s m a @@ -70,11 +72,18 @@ optionMaybe :: forall m s a. Monad m => ParserT s m a -> ParserT s m (Maybe a) optionMaybe p = option Nothing (Just <$> p) -- | In case of failure, reset the stream to the unconsumed state. -try :: forall m s a. (Functor m) => ParserT s m a -> ParserT s m a -try p = ParserT $ \(PState { input: s, position: pos }) -> try' s pos <$> unParserT p (PState { input: s, position: pos }) - where - try' s pos o@{ result: Left _ } = { input: s, result: o.result, consumed: false, position: pos } - try' _ _ o = o +try :: forall m s a. Monad m => ParserT s m a -> ParserT s m a +try p = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState _ _ consumed)) -> do + Tuple e s'@(ParseState input position _) <- runStateT (runExceptT (unwrap p)) s + case e of + Left _ -> pure (Tuple e (ParseState input position consumed)) + _ -> pure (Tuple e s') + +-- | Parse a phrase, without modifying the consumed state or stream position. +lookAhead :: forall s a m. Monad m => ParserT s m a -> ParserT s m a +lookAhead p = (ParserT <<< ExceptT <<< StateT) \s -> do + Tuple e _ <- runStateT (runExceptT (unwrap p)) s + pure (Tuple e s) -- | Parse phrases delimited by a separator. -- | @@ -172,12 +181,6 @@ skipMany1 p = do xs <- skipMany p pure unit --- | Parse a phrase, without modifying the consumed state or stream position. -lookAhead :: forall s a m. Monad m => ParserT s m a -> ParserT s m a -lookAhead (ParserT p) = ParserT \(PState { input: s, position: pos }) -> do - state <- p (PState { input: s, position: pos }) - pure state{input = s, consumed = false, position = pos} - -- | Fail if the specified parser matches. notFollowedBy :: forall s a m. Monad m => ParserT s m a -> ParserT s m Unit notFollowedBy p = try $ (try p *> fail "Negated parser succeeded") <|> pure unit diff --git a/src/Text/Parsing/Parser/Pos.purs b/src/Text/Parsing/Parser/Pos.purs index 5273828..e9dac1b 100644 --- a/src/Text/Parsing/Parser/Pos.purs +++ b/src/Text/Parsing/Parser/Pos.purs @@ -1,15 +1,15 @@ module Text.Parsing.Parser.Pos where import Prelude - -import Data.String (split) import Data.Foldable (foldl) +import Data.Newtype (wrap) +import Data.String (split) -- | `Position` represents the position of the parser in the input. -- | -- | - `line` is the current line in the input -- | - `column` is the column of the next character in the current line that will be parsed -data Position = Position +newtype Position = Position { line :: Int , column :: Int } @@ -18,9 +18,8 @@ instance showPosition :: Show Position where show (Position { line: line, column: column }) = "Position { line: " <> show line <> ", column: " <> show column <> " }" -instance eqPosition :: Eq Position where - eq (Position { line: l1, column: c1 }) (Position { line: l2, column: c2 }) = - l1 == l2 && c1 == c2 +derive instance eqPosition :: Eq Position +derive instance ordPosition :: Ord Position -- | The `Position` before any input has been parsed. initialPos :: Position @@ -28,7 +27,7 @@ initialPos = Position { line: 1, column: 1 } -- | Updates a `Position` by adding the columns and lines in `String`. updatePosString :: Position -> String -> Position -updatePosString pos str = foldl updatePosChar pos (split "" str) +updatePosString pos str = foldl updatePosChar pos (split (wrap "") str) where updatePosChar (Position pos) c = case c of "\n" -> Position { line: pos.line + 1, column: 1 } diff --git a/src/Text/Parsing/Parser/String.purs b/src/Text/Parsing/Parser/String.purs index a4e20f9..002e231 100644 --- a/src/Text/Parsing/Parser/String.purs +++ b/src/Text/Parsing/Parser/String.purs @@ -2,65 +2,91 @@ module Text.Parsing.Parser.String where -import Prelude hiding (between) - +import Data.String as S +import Control.Monad.State (modify, gets) import Data.Array (many) -import Data.Either (Either(..)) import Data.Foldable (elem, notElem) import Data.Maybe (Maybe(..)) -import Data.String (charAt, drop, fromCharArray, indexOf, length, singleton) -import Text.Parsing.Parser (PState(..), ParserT(..), fail, parseFailed) -import Text.Parsing.Parser.Combinators (try) +import Data.Newtype (wrap) +import Data.String (Pattern, fromCharArray, length, singleton) +import Text.Parsing.Parser (ParseState(..), ParserT, fail) +import Text.Parsing.Parser.Combinators (try, ()) import Text.Parsing.Parser.Pos (updatePosString) +import Prelude hiding (between) + +-- | This class exists to abstract over streams which support the string-like +-- | operations which this modules needs. +class StringLike s where + drop :: Int -> s -> s + indexOf :: Pattern -> s -> Maybe Int + null :: s -> Boolean + uncons :: s -> Maybe { head :: Char, tail :: s } + +instance stringLikeString :: StringLike String where + uncons = S.uncons + drop = S.drop + indexOf = S.indexOf + null = S.null -- | Match end-of-file. -eof :: forall m. (Monad m) => ParserT String m Unit -eof = ParserT $ \(PState { input: s, position: pos }) -> - pure $ case s of - "" -> { consumed: false, input: s, result: Right unit, position: pos } - _ -> parseFailed s pos "Expected EOF" +eof :: forall s m. (StringLike s, Monad m) => ParserT s m Unit +eof = do + input <- gets \(ParseState input _ _) -> input + unless (null input) (fail "Expected EOF") -- | Match the specified string. -string :: forall m. (Monad m) => String -> ParserT String m String -string str = ParserT $ \(PState { input: s, position: pos }) -> - pure $ case indexOf str s of - Just 0 -> { consumed: true, input: drop (length str) s, result: Right str, position: updatePosString pos str } - _ -> parseFailed s pos ("Expected " <> str) +string :: forall s m. (StringLike s, Monad m) => String -> ParserT s m String +string str = do + input <- gets \(ParseState input _ _) -> input + case indexOf (wrap str) input of + Just 0 -> do + modify \(ParseState _ position _) -> + ParseState (drop (length str) input) + (updatePosString position str) + true + pure str + _ -> fail ("Expected " <> show str) -- | Match any character. -anyChar :: forall m. (Monad m) => ParserT String m Char -anyChar = ParserT $ \(PState { input: s, position: pos }) -> - pure $ case charAt 0 s of - Nothing -> parseFailed s pos "Unexpected EOF" - Just c -> { consumed: true, input: drop 1 s, result: Right c, position: updatePosString pos (singleton c) } +anyChar :: forall s m. (StringLike s, Monad m) => ParserT s m Char +anyChar = do + input <- gets \(ParseState input _ _) -> input + case uncons input of + Nothing -> fail "Unexpected EOF" + Just { head, tail } -> do + modify \(ParseState _ position _) -> + ParseState tail + (updatePosString position (singleton head)) + true + pure head -- | Match a character satisfying the specified predicate. -satisfy :: forall m. (Monad m) => (Char -> Boolean) -> ParserT String m Char +satisfy :: forall s m. (StringLike s, Monad m) => (Char -> Boolean) -> ParserT s m Char satisfy f = try do c <- anyChar if f c then pure c else fail $ "Character '" <> singleton c <> "' did not satisfy predicate" -- | Match the specified character -char :: forall m. (Monad m) => Char -> ParserT String m Char -char c = satisfy (_ == c) +char :: forall s m. (StringLike s, Monad m) => Char -> ParserT s m Char +char c = satisfy (_ == c) ("Expected " <> show c) -- | Match a whitespace character. -whiteSpace :: forall m. (Monad m) => ParserT String m String +whiteSpace :: forall s m. (StringLike s, Monad m) => ParserT s m String whiteSpace = do cs <- many $ satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t' pure $ fromCharArray cs -- | Skip whitespace characters. -skipSpaces :: forall m. (Monad m) => ParserT String m Unit +skipSpaces :: forall s m. (StringLike s, Monad m) => ParserT s m Unit skipSpaces = do whiteSpace pure unit -- | Match one of the characters in the array. -oneOf :: forall m. (Monad m) => Array Char -> ParserT String m Char -oneOf ss = satisfy (flip elem ss) +oneOf :: forall s m. (StringLike s, Monad m) => Array Char -> ParserT s m Char +oneOf ss = satisfy (flip elem ss) ("Expected one of " <> show ss) -- | Match any character not in the array. -noneOf :: forall m. (Monad m) => Array Char -> ParserT String m Char -noneOf ss = satisfy (flip notElem ss) +noneOf :: forall s m. (StringLike s, Monad m) => Array Char -> ParserT s m Char +noneOf ss = satisfy (flip notElem ss) ("Expected none of " <> show ss) diff --git a/src/Text/Parsing/Parser/Token.purs b/src/Text/Parsing/Parser/Token.purs index ad3845f..d54a228 100644 --- a/src/Text/Parsing/Parser/Token.purs +++ b/src/Text/Parsing/Parser/Token.purs @@ -21,38 +21,39 @@ module Text.Parsing.Parser.Token ) where -import Prelude hiding (when, between) - +import Data.Array as Array +import Data.Char.Unicode as Unicode +import Data.List as List import Control.Lazy (fix) +import Control.Monad.State (modify, gets) import Control.MonadPlus (guard, (<|>)) - -import Data.Array as Array import Data.Char (fromCharCode, toCharCode) import Data.Char.Unicode (digitToInt, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit, isSpace, isUpper) -import Data.Char.Unicode as Unicode import Data.Either (Either(..)) import Data.Foldable (foldl, foldr) import Data.Identity (Identity) import Data.Int (toNumber) import Data.List (List(..)) -import Data.List as List import Data.Maybe (Maybe(..), maybe) import Data.String (toCharArray, null, toLower, fromCharArray, singleton, uncons) import Data.Tuple (Tuple(..)) - import Math (pow) - -import Text.Parsing.Parser (PState(..), ParserT(..), fail, parseFailed) +import Text.Parsing.Parser (ParseState(..), ParserT, fail) import Text.Parsing.Parser.Combinators (skipMany1, try, skipMany, notFollowedBy, option, choice, between, sepBy1, sepBy, (), ()) import Text.Parsing.Parser.Pos (Position) import Text.Parsing.Parser.String (satisfy, oneOf, noneOf, string, char) +import Prelude hiding (when,between) -- | Create a parser which Returns the first token in the stream. token :: forall m a. Monad m => (a -> Position) -> ParserT (List a) m a -token tokpos = ParserT $ \(PState { input: toks, position: pos }) -> - pure $ case toks of - Cons x xs -> { consumed: true, input: xs, result: Right x, position: tokpos x } - _ -> parseFailed toks pos "expected token, met EOF" +token tokpos = do + input <- gets \(ParseState input _ _) -> input + case List.uncons input of + Nothing -> fail "Unexpected EOF" + Just { head, tail } -> do + modify \(ParseState _ position _) -> + ParseState tail (tokpos head) true + pure head -- | Create a parser which matches any token satisfying the predicate. when :: forall m a. Monad m => (a -> Position) -> (a -> Boolean) -> ParserT (List a) m a @@ -640,7 +641,7 @@ makeTokenParser (LanguageDef languageDef) go = caseString name *> (notFollowedBy languageDef.identLetter "end of " <> name) caseString :: String -> ParserT String m String - caseString name | languageDef.caseSensitive = string name + caseString name | languageDef.caseSensitive = string name $> name | otherwise = walk name $> name where walk :: String -> ParserT String m Unit @@ -681,7 +682,7 @@ makeTokenParser (LanguageDef languageDef) -- White space & symbols ----------------------------------------------------------- symbol :: String -> ParserT String m String - symbol name = lexeme (string name) + symbol name = lexeme (string name) $> name lexeme :: forall a . ParserT String m a -> ParserT String m a lexeme p = p <* whiteSpace' (LanguageDef languageDef) diff --git a/test/Main.purs b/test/Main.purs index 1adf1ea..5cd11ba 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,45 +1,47 @@ module Test.Main where -import Prelude hiding (between, when) - import Control.Alt ((<|>)) -import Control.Apply ((*>)) import Control.Lazy (fix) import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE) +import Control.Monad.Eff.Console (logShow, CONSOLE) import Data.Array (some) import Data.Either (Either(..)) -import Data.Functor (($>)) import Data.List (List(..), fromFoldable, many) import Data.Maybe (Maybe(..)) import Data.String (fromCharArray, singleton) import Data.Tuple (Tuple(..)) import Test.Assert (ASSERT, assert') -import Text.Parsing.Parser (Parser, ParserT, ParseError(..), runParser) +import Text.Parsing.Parser (Parser, ParserT, runParser, parseErrorPosition) import Text.Parsing.Parser.Combinators (endBy1, sepBy1, optionMaybe, try, chainl, between) import Text.Parsing.Parser.Expr (Assoc(..), Operator(..), buildExprParser) import Text.Parsing.Parser.Language (javaStyle, haskellStyle, haskellDef) import Text.Parsing.Parser.Pos (Position(..), initialPos) import Text.Parsing.Parser.String (eof, string, char, satisfy, anyChar) import Text.Parsing.Parser.Token (TokenParser, match, when, token, makeTokenParser) +import Prelude hiding (between,when) parens :: forall m a. Monad m => ParserT String m a -> ParserT String m a parens = between (string "(") (string ")") -nested :: forall m. (Functor m, Monad m) => ParserT String m Int +nested :: forall m. Monad m => ParserT String m Int nested = fix \p -> (do string "a" pure 0) <|> ((+) 1) <$> parens p parseTest :: forall s a eff. (Show a, Eq a) => s -> a -> Parser s a -> Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit parseTest input expected p = case runParser input p of - Right actual -> assert' ("expected: " <> show expected <> ", actual: " <> show actual) (expected == actual) + Right actual -> do + assert' ("expected: " <> show expected <> ", actual: " <> show actual) (expected == actual) + logShow actual Left err -> assert' ("error: " <> show err) false parseErrorTestPosition :: forall s a eff. (Show a) => Parser s a -> s -> Position -> Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit parseErrorTestPosition p input expected = case runParser input p of Right _ -> assert' "error: ParseError expected!" false - Left (ParseError { position: pos }) -> assert' ("expected: " <> show expected <> ", pos: " <> show pos) (expected == pos) + Left err -> do + let pos = parseErrorPosition err + assert' ("expected: " <> show expected <> ", pos: " <> show pos) (expected == pos) + logShow expected opTest :: Parser String String opTest = chainl (singleton <$> anyChar) (char '+' $> append) "" @@ -415,7 +417,7 @@ main = do parseErrorTestPosition (many $ char 'f' *> char '?') "foo" - (Position { column: 3, line: 1 }) + (Position { column: 2, line: 1 }) parseTest "foo"