Generalize StringLike to StreamLike fix

.travis.yml

@@ -8,6 +8,7 @@ install:
   - bower install
 script:
   - npm run -s build
+  - npm run -s test
 after_success:
 - >-
   test $TRAVIS_TAG &&

bower.json

@@ -25,7 +25,7 @@
     "purescript-foldable-traversable": "^3.0.0",
     "purescript-identity": "^3.0.0",
     "purescript-integers": "^3.0.0",
-    "purescript-lists": "^4.0.0",
+    "purescript-lists": "^4.6.0",
     "purescript-maybe": "^3.0.0",
     "purescript-strings": "^3.0.0",
     "purescript-transformers": "^3.0.0",

package.json

@@ -2,7 +2,8 @@
   "private": true,
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
-    "build": "pulp build && pulp test"
+    "build": "pulp build",
+    "test": "pulp test"
   },
   "devDependencies": {
     "pulp": "^11.0.0",

src/Text/Parsing/Parser.purs

@@ -1,16 +1,20 @@
 module Text.Parsing.Parser
-  ( ParseError
+  ( ParseError(..)
   , parseErrorMessage
   , parseErrorPosition
   , ParseState(..)
   , ParserT(..)
   , Parser
   , runParser
   , runParserT
+  , unParserT
+  , inParserT
   , hoistParserT
   , mapParserT
   , consume
+  , position
   , fail
+  , failWithPosition
   ) where
 
 import Prelude
@@ -20,14 +24,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 (runStateT, class MonadState, StateT(..), gets, evalStateT, mapStateT, modify)
+import Control.Monad.State (runStateT, class MonadState, StateT(..), gets, mapStateT, modify)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Control.MonadPlus (class Alternative, class MonadZero, class MonadPlus, class Plus)
 import Data.Either (Either(..))
 import Data.Identity (Identity)
 import Data.Monoid (class Monoid, mempty)
 import Data.Newtype (class Newtype, unwrap, over)
-import Data.Tuple (Tuple(..))
+import Data.Tuple (Tuple(..), fst)
 import Text.Parsing.Parser.Pos (Position, initialPos)
 
 -- | A parsing error, consisting of a message and position information.
@@ -47,7 +51,9 @@ derive instance eqParseError :: Eq ParseError
 derive instance ordParseError :: Ord ParseError
 
 -- | Contains the remaining input and current position.
-data ParseState s = ParseState s Position Boolean
+-- data ParseState s = ParseState s Position Boolean
+newtype ParseState s = ParseState
+  { input :: s, pos :: Position, consumed :: Boolean }
 
 -- | The Parser monad transformer.
 -- |
@@ -59,8 +65,23 @@ derive instance newtypeParserT :: Newtype (ParserT s m a) _
 
 -- | Apply a parser, keeping only the parsed 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
+runParserT input p = fst <$> unParserT p initialState
+  where
+  initialState = ParseState { input, pos: initialPos, consumed: false }
+
+-- Reveals inner function of parser
+unParserT :: forall m s a
+   . Monad m
+  => ParserT s m a
+  -> (ParseState s -> m (Tuple (Either ParseError a) (ParseState s)))
+unParserT (ParserT p) = runStateT $ runExceptT p
+
+-- Takes inner function of Parser and constructs one
+inParserT :: forall m s a
+   . Monad m
+  => (ParseState s -> m (Tuple (Either ParseError a) (ParseState s)))
+  -> ParserT s m a
+inParserT = ParserT <<< ExceptT <<< StateT
 
 -- | The `Parser` monad is a synonym for the parser monad transformer applied to the `Identity` monad.
 type Parser s = ParserT s Identity
@@ -99,12 +120,12 @@ derive newtype instance monadThrowParserT :: Monad m => MonadThrow ParseError (P
 derive newtype instance monadErrorParserT :: Monad m => MonadError ParseError (ParserT s m)
 
 instance altParserT :: Monad m => Alt (ParserT s m) where
-  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')
+  alt p1 p2 = inParserT \(ParseState state) ->
+    unParserT p1 (ParseState (state{consumed = false})) >>= \(Tuple e (ParseState nextState)) ->
+      case e of
+        Left err
+          | not nextState.consumed -> unParserT p2 (ParseState state)
+        _ -> pure (Tuple e (ParseState nextState))
 
 instance plusParserT :: Monad m => Plus (ParserT s m) where
   empty = fail "No alternative"
@@ -120,11 +141,17 @@ instance monadTransParserT :: MonadTrans (ParserT s) where
 
 -- | Set the consumed flag.
 consume :: forall s m. Monad m => ParserT s m Unit
-consume = modify \(ParseState input position _) ->
-  ParseState input position true
+consume = modify \(ParseState state) ->
+  ParseState state{consumed = true}
+
+-- | Returns the current position in the stream.
+position :: forall s m. Monad m => ParserT s m Position
+position = gets \(ParseState state) -> state.pos
 
 -- | Fail with a message.
 fail :: forall m s a. Monad m => String -> ParserT s m a
-fail message = do
-  position <- gets \(ParseState _ pos _) -> pos
-  throwError (ParseError message position)
+fail message = failWithPosition message =<< position
+
+-- | Fail with a message and a position.
+failWithPosition :: forall m s a. Monad m => String -> Position -> ParserT s m a
+failWithPosition message pos = throwError (ParseError message pos)

src/Text/Parsing/Parser/Combinators.purs

@@ -15,22 +15,19 @@
 -- | be used in conjunction with `Data.String.fromCharArray` to achieve "Parsec-like" results.
 -- |
 -- | ```purescript
--- | Text.Parsec.many  (char 'x') <=> fromCharArray <$> Data.Array.many (char 'x')
+-- | Text.Parsec.many  (match 'x') <=> fromCharArray <$> Data.Array.many (match 'x')
 -- | ```
 
 module Text.Parsing.Parser.Combinators where
 
 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 Data.Newtype (unwrap)
 import Data.Tuple (Tuple(..))
-import Text.Parsing.Parser (ParseState(..), ParserT(..), fail)
+import Text.Parsing.Parser (ParseState(..), ParserT, ParseError(..), unParserT, inParserT, 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
@@ -49,7 +46,7 @@ infix 3 asErrorMessage as <??>
 -- | For example:
 -- |
 -- | ```purescript
--- | parens = between (string "(") (string ")")
+-- | parens = between (prefix "(") (prefix ")")
 -- | ```
 between :: forall m s a open close. Monad m => ParserT s m open -> ParserT s m close -> ParserT s m a -> ParserT s m a
 between open close p = open *> p <* close
@@ -68,24 +65,36 @@ optionMaybe p = option Nothing (Just <$> p)
 
 -- | In case of failure, reset the stream to the unconsumed state.
 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')
+try p = inParserT \(ParseState state) ->
+  unParserT p (ParseState state) <#> \(Tuple e (ParseState nextState)) ->
+    case e of
+      Left _ -> Tuple e (ParseState nextState{consumed = state.consumed})
+      Right _ -> Tuple e (ParseState nextState)
+
+-- | Like `try`, but will reannotate the error location to the `try` point.
+tryRethrow :: forall m s a. Monad m => ParserT s m a -> ParserT s m a
+tryRethrow p = inParserT \(ParseState state) ->
+  unParserT p (ParseState state) <#> \(Tuple e (ParseState nextState)) ->
+    case e of
+      Left (ParseError err _) ->
+        Tuple
+          (Left (ParseError err state.pos))
+          (ParseState nextState{consumed = state.consumed})
+      Right _ ->
+        Tuple e (ParseState nextState)
 
 -- | 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
+lookAhead p = inParserT \s -> do
+  Tuple e _ <- unParserT p s
   pure (Tuple e s)
 
 -- | Parse phrases delimited by a separator.
 -- |
 -- | For example:
 -- |
 -- | ```purescript
--- | digit `sepBy` string ","
+-- | digit `sepBy` prefix ","
 -- | ```
 sepBy :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a)
 sepBy p sep = sepBy1 p sep <|> pure Nil
@@ -122,7 +131,7 @@ endBy p sep = many $ p <* sep
 -- | For example:
 -- |
 -- | ```purescript
--- | chainr digit (string "+" *> add) 0
+-- | chainr digit (prefix "+" *> add) 0
 -- | ```
 chainr :: forall m s a. Monad m => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
 chainr p f a = chainr1 p f <|> pure a

src/Text/Parsing/Parser/Expr.purs

@@ -32,10 +32,10 @@ type SplitAccum m s a = { rassoc  :: List (ParserT s m (a -> a -> a))
 -- | For example:
 -- |
 -- | ```purescript
--- | buildExprParser [ [ Infix (string "/" $> div) AssocRight ]
--- |                 , [ Infix (string "*" $> mul) AssocRight ]
--- |                 , [ Infix (string "-" $> sub) AssocRight ]
--- |                 , [ Infix (string "+" $> add) AssocRight ]
+-- | buildExprParser [ [ Infix (prefix "/" $> div) AssocRight ]
+-- |                 , [ Infix (prefix "*" $> mul) AssocRight ]
+-- |                 , [ Infix (prefix "-" $> sub) AssocRight ]
+-- |                 , [ Infix (prefix "+" $> add) AssocRight ]
 -- |                 ] digit
 -- | ```
 buildExprParser :: forall m s a. Monad m => OperatorTable m s a -> ParserT s m a -> ParserT s m a

src/Text/Parsing/Parser/Indent.purs

@@ -59,10 +59,10 @@ import Control.Monad.State.Trans (get, put)
 import Control.Monad.Trans.Class (lift)
 import Data.List (List(..), many)
 import Data.Maybe (Maybe(..))
-import Text.Parsing.Parser (ParserT, ParseState(ParseState), fail)
+import Text.Parsing.Parser (ParserT, ParseState(..), fail)
 import Text.Parsing.Parser.Combinators (option, optionMaybe)
 import Text.Parsing.Parser.Pos (Position(..), initialPos)
-import Text.Parsing.Parser.String (string, oneOf)
+import Text.Parsing.Parser.Stream (prefix, oneOf)
 
 -- | Indentation sensitive parser type. Usually @ m @ will
 -- | be @ Identity @ as with any @ ParserT @
@@ -71,7 +71,7 @@ type IndentParser s a = ParserT s (State Position) a
 -- | @ getPosition @ returns current position
 -- | should probably be added to Text.Parsing.Parser.Pos
 getPosition :: forall m s. (Monad m) => ParserT s m Position
-getPosition = gets \(ParseState _ pos _) -> pos
+getPosition = gets \(ParseState state) -> state.pos
 
 -- | simple helper function to avoid typ-problems with MonadState instance
 get' :: forall s. IndentParser s Position
@@ -100,7 +100,7 @@ many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
 many1 p = lift2 Cons p (many p)
 
 symbol :: forall m. (Monad m) => String -> ParserT String m String
-symbol name = (many $ oneOf [' ','\t']) *> (string name)
+symbol name = (many $ oneOf [' ','\t']) *> (prefix name)
 
 -- | `withBlock f a p` parses `a`
 -- | followed by an indented block of `p`

src/Text/Parsing/Parser/Language.purs

@@ -12,8 +12,9 @@ import Prelude
 
 import Control.Alt ((<|>))
 import Text.Parsing.Parser (ParserT)
-import Text.Parsing.Parser.String (char, oneOf)
-import Text.Parsing.Parser.Token (LanguageDef, TokenParser, GenLanguageDef(..), unGenLanguageDef, makeTokenParser, alphaNum, letter)
+import Text.Parsing.Parser.Stream (match, oneOf)
+import Text.Parsing.Parser.String (alphaNum, letter)
+import Text.Parsing.Parser.Token (LanguageDef, TokenParser, GenLanguageDef(..), unGenLanguageDef, makeTokenParser)
 
 -----------------------------------------------------------
 -- Styles: haskellStyle, javaStyle
@@ -70,7 +71,7 @@ emptyDef = LanguageDef
             , commentEnd:      ""
             , commentLine:     ""
             , nestedComments:  true
-            , identStart:      letter <|> char '_'
+            , identStart:      letter <|> match '_'
             , identLetter:     alphaNum <|> oneOf ['_', '\'']
             , opStart:         op'
             , opLetter:        op'
@@ -95,7 +96,7 @@ haskellDef  :: LanguageDef
 haskellDef   =
     case haskell98Def of
         (LanguageDef def) -> LanguageDef def
-                { identLetter    = def.identLetter <|> char '#'
+                { identLetter    = def.identLetter <|> match '#'
                 , reservedNames  = def.reservedNames <>
                                    ["foreign","import","export","primitive"
                                    ,"_ccall_","_casm_"

src/Text/Parsing/Parser/Pos.purs

@@ -2,8 +2,7 @@ module Text.Parsing.Parser.Pos where
 
 import Prelude
 import Data.Foldable (foldl)
-import Data.Newtype (wrap)
-import Data.String (split)
+import Data.String (toCharArray)
 
 -- | `Position` represents the position of the parser in the input.
 -- |
@@ -27,10 +26,11 @@ 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 (wrap "") str)
-  where
-  updatePosChar (Position pos) c = case c of
-    "\n" -> Position { line: pos.line + 1, column: 1 }
-    "\r" -> Position { line: pos.line + 1, column: 1 }
-    "\t" -> Position { line: pos.line,     column: pos.column + 8 - ((pos.column - 1) `mod` 8) }
-    _    -> Position { line: pos.line,     column: pos.column + 1 }
+updatePosString pos' str = foldl updatePosChar pos' (toCharArray str)
+
+updatePosChar :: Position -> Char -> Position
+updatePosChar (Position pos) c = case c of
+  '\n' -> Position { line: pos.line + 1, column: 1 }
+  '\r' -> Position { line: pos.line + 1, column: 1 }
+  '\t' -> Position { line: pos.line,     column: pos.column + 8 - ((pos.column - 1) `mod` 8) }
+  _    -> Position { line: pos.line,     column: pos.column + 1 }