Avoids closure in Stream class

s -> m (Maybe { head :: t, tail :: s, updatePos :: Position -> Position })
instead of having updatePos as a result of uncons or stripPrefix now this operations take position with input which is part of a parser state. this way we should allocation less of intermediate objects.

Author: safareli

src/Text/Parsing/Parser.purs

@@ -7,6 +7,8 @@ module Text.Parsing.Parser
   , Parser
   , runParser
   , runParserT
+  , unParserT
+  , inParserT
   , hoistParserT
   , mapParserT
   , consume
@@ -22,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.
@@ -49,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.
 -- |
@@ -61,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
@@ -101,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"
@@ -122,12 +141,12 @@ instance monadTransParserT :: MonadTrans (ParserT s) where
 
 -- | Set the consumed flag.
 consume :: forall s m. Monad m => ParserT s m Unit
-consume = modify \(ParseState input pos _) ->
-  ParseState input pos 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 _ pos _) -> pos
+position = gets \(ParseState state) -> state.pos
 
 -- | Fail with a message.
 fail :: forall m s a. Monad m => String -> ParserT s m a

src/Text/Parsing/Parser/Combinators.purs

@@ -21,16 +21,14 @@
 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(..), ParseError(..), 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
@@ -68,24 +66,28 @@ 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 = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState _ position consumed)) -> do
-  Tuple e s'@(ParseState input' position' _) <- runStateT (runExceptT (unwrap p)) s
-  case e of
-    Left (ParseError err _) -> pure (Tuple (Left (ParseError err position)) (ParseState input' position' consumed))
-    _ -> pure (Tuple e s')
+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.

src/Text/Parsing/Parser/Indent.purs

@@ -59,7 +59,7 @@ 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.Stream (prefix, oneOf)
@@ -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

src/Text/Parsing/Parser/Stream.purs

@@ -2,15 +2,15 @@
 
 module Text.Parsing.Parser.Stream where
 
-import Control.Monad.State (modify, gets)
+import Control.Monad.State (put, get)
 import Control.Monad.Trans.Class (lift)
-import Data.Foldable (fold, elem, notElem)
+import Data.Foldable (foldl, elem, notElem)
 import Data.List as L
 import Data.List.Lazy as LazyL
 import Data.Maybe (Maybe(..))
-import Data.Monoid.Endo (Endo(..))
-import Data.Newtype (class Newtype, unwrap)
+import Data.Newtype (class Newtype)
 import Data.String as S
+import Data.Tuple (Tuple(..))
 import Prelude hiding (between)
 import Text.Parsing.Parser (ParseState(..), ParserT, fail)
 import Text.Parsing.Parser.Combinators (tryRethrow, (<?>))
@@ -36,60 +36,63 @@ instance charHasUpdatePosition :: HasUpdatePosition Char where
   updatePos = updatePosChar
 
 -- | This class exists to abstract over streams which support the string-like
--- | operations which this modules needs.
+-- | operations with position tracking, which this modules needs.
 -- |
 -- | Instances must satisfy the following laws:
--- | - `stripPrefix (Prefix a) a >>= uncons = Nothing`
+-- | - `stripPrefix (Prefix input) {input, position} >>= uncons = Nothing`
+
 class Stream s m t | s -> t where
-  uncons :: s -> m (Maybe { head :: t, tail :: s, updatePos :: Position -> Position })
-  stripPrefix :: Prefix s -> s -> m (Maybe {  rest :: s, updatePos :: Position -> Position })
+  uncons :: forall r. ParserCursor s r -> m (Maybe (Tuple t (ParserCursor s r)))
+  stripPrefix :: forall r. Prefix s -> ParserCursor s r -> m (Maybe (ParserCursor s r))
+
+-- Part or ParseState which is exposed to Stream instances
+type ParserCursor s r = { input :: s, pos :: Position | r}
+
 
-instance stringStream :: (Applicative m) =>  Stream String m Char where
-  uncons f = pure $ S.uncons f <#> \({ head, tail}) ->
-    { head, tail, updatePos: (_ `updatePos` head)}
-  stripPrefix (Prefix p) s = pure $ S.stripPrefix (S.Pattern p) s <#> \rest ->
-    { rest, updatePos: (_ `updatePos` p)}
+instance stringStream :: (Applicative m) => Stream String m Char where
+  uncons state = pure $ S.uncons state.input <#> \({ head, tail}) ->
+    Tuple head state{input = tail, pos = updatePos state.pos head }
+  stripPrefix (Prefix p) state = pure $ S.stripPrefix (S.Pattern p) state.input <#> \rest ->
+    state{input = rest, pos = updatePos state.pos p}
 
 instance listStream :: (Applicative m, Eq a, HasUpdatePosition a) => Stream (L.List a) m a where
-  uncons f = pure $ L.uncons f <#> \({ head, tail}) ->
-    { head, tail, updatePos: (_ `updatePos` head)}
-  stripPrefix (Prefix p) s = pure $ L.stripPrefix (L.Pattern p) s <#> \rest ->
-    { rest, updatePos: unwrap (fold (p <#> (flip updatePos >>> Endo)))}
+  uncons state = pure $ L.uncons state.input <#> \({ head, tail}) ->
+    Tuple head state{input = tail, pos = updatePos state.pos head }
+  stripPrefix (Prefix p) state = pure $ L.stripPrefix (L.Pattern p) state.input <#> \rest ->
+    state{input = rest, pos = foldl updatePos state.pos p}
 
 instance lazyListStream :: (Applicative m, Eq a, HasUpdatePosition a) => Stream (LazyL.List a) m a where
-  uncons f = pure $ LazyL.uncons f <#> \({ head, tail}) ->
-    { head, tail, updatePos: (_ `updatePos` head)}
-  stripPrefix (Prefix p) s = pure $ LazyL.stripPrefix (LazyL.Pattern p) s <#> \rest ->
-    { rest, updatePos: unwrap (fold (p <#> (flip updatePos >>> Endo)))}
+  uncons state = pure $ LazyL.uncons state.input <#> \({ head, tail}) ->
+    Tuple head state{input = tail, pos = updatePos state.pos head }
+  stripPrefix (Prefix p) state = pure $ LazyL.stripPrefix (LazyL.Pattern p) state.input <#> \rest ->
+    state{input = rest, pos = foldl updatePos state.pos p}
 
 -- | Match end of stream.
 eof :: forall s t m. Stream s m t => Monad m => ParserT s m Unit
 eof = do
-  input <- gets \(ParseState input _ _) -> input
-  (lift $ uncons input) >>= case _ of
+  ParseState state <- get
+  (lift $ uncons state) >>= case _ of
     Nothing -> pure unit
     _ -> fail "Expected EOF"
 
 -- | Match the specified prefix.
 prefix :: forall f c m. Stream f m c => Show f => Monad m => f -> ParserT f m f
 prefix p = do
-  input <- gets \(ParseState input _ _) -> input
-  (lift $ stripPrefix (Prefix p) input) >>= case _ of
-    Just {rest, updatePos} -> do
-      modify \(ParseState _ position _) ->
-        ParseState rest (updatePos position) true
+  ParseState state <- get
+  (lift $ stripPrefix (Prefix p) state) >>= case _ of
+    Nothing -> fail $ "Expected " <> show p
+    Just state -> do
+      put $ ParseState state{consumed = true}
       pure p
-    _ -> fail ("Expected " <> show p)
 
 -- | Match any token.
 token :: forall s t m. Stream s m t => Monad m => ParserT s m t
 token = do
-  input <- gets \(ParseState input _ _) -> input
-  (lift $ uncons input) >>= case _ of
+  ParseState state <- get
+  (lift $ uncons state) >>= case _ of
     Nothing -> fail "Unexpected EOF"
-    Just ({ head, updatePos, tail }) -> do
-      modify \(ParseState _ position _) ->
-        ParseState tail (updatePos position) true
+    Just (Tuple head nextState) -> do
+      put $ ParseState nextState{consumed = true}
       pure head
 
 -- | Match a token satisfying the specified predicate.