Generalize StringLike to StreamLike fix #58

.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/Pos.purs

@@ -3,7 +3,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 +27,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 }

src/Text/Parsing/Parser/String.purs

@@ -2,89 +2,118 @@
 
 module Text.Parsing.Parser.String where
 
+import Data.Array (many, toUnfoldable)
+import Data.Foldable (fold, elem, notElem)
+import Data.List as L
+import Data.Monoid (class Monoid)
+import Data.Monoid.Endo (Endo(..))
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype, unwrap)
 import Data.String as S
+import Data.Unfoldable (class Unfoldable)
 import Control.Monad.State (modify, gets)
-import Data.Array (many)
-import Data.Foldable (elem, notElem)
-import Data.Maybe (Maybe(..))
-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 Text.Parsing.Parser.Pos (Position, updatePosString, updatePosChar)
 import Prelude hiding (between)
 
+-- | A newtype used in cases where there is a prefix to be droped.
+newtype Prefix a = Prefix a
+
+derive instance eqPrefix :: Eq a => Eq (Prefix a)
+derive instance ordPrefix :: Ord a => Ord (Prefix a)
+derive instance newtypePrefix :: Newtype (Prefix a) _
+
+instance showPrefix :: Show a => Show (Prefix a) where
+  show (Prefix s) = "(Prefix " <> show s <> ")"
+
+class HasUpdatePosition a where
+  updatePos :: Position -> a -> Position
+
+instance stringHasUpdatePosition :: HasUpdatePosition String where
+  updatePos = updatePosString
+
+instance charHasUpdatePosition :: HasUpdatePosition Char where
+  updatePos = updatePosChar
+
 -- | 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 s m. StringLike s => Monad m => ParserT s m Unit
+-- |
+-- | Instances must satisfy the following laws:
+-- |
+class StreamLike f c | f -> c where
+  uncons :: f -> Maybe { head :: c, tail :: f, updatePos :: Position -> Position }
+  drop :: Prefix f -> f -> Maybe {  rest :: f, updatePos :: Position -> Position }
+
+instance stringStreamLike :: StreamLike String Char where
+  uncons f = S.uncons f <#> \({ head, tail}) ->
+    { head, tail, updatePos: (_ `updatePos` head)}
+  drop (Prefix p) s = S.stripPrefix (S.Pattern p) s <#> \rest ->
+    { rest, updatePos: (_ `updatePos` p)}
+
+instance listcharStreamLike :: (Eq a, HasUpdatePosition a) => StreamLike (L.List a) a where
+  uncons f = L.uncons f <#> \({ head, tail}) ->
+    { head, tail, updatePos: (_ `updatePos` head)}
+  drop (Prefix p) s = L.stripPrefix (L.Pattern p) s <#> \rest ->
+    { rest, updatePos: unwrap (fold (p <#> (flip updatePos >>> Endo)))}
+
+-- | Match end of stream.
+eof :: forall f c m. StreamLike f c => Monad m => ParserT f m Unit
 eof = do
   input <- gets \(ParseState input _ _) -> input
-  unless (null input) (fail "Expected EOF")
+  case uncons input of
+    Nothing -> pure unit
+    _ -> fail "Expected EOF"
 
--- | Match the specified string.
-string :: forall s m. StringLike s => Monad m => String -> ParserT s m String
+-- | Match the specified stream.
+string :: forall f c m. StreamLike f c => Show f => Monad m => f -> ParserT f m f
 string str = do
   input <- gets \(ParseState input _ _) -> input
-  case indexOf (wrap str) input of
-    Just 0 -> do
+  case drop (Prefix str) input of
+    Just {rest, updatePos} -> do
       modify \(ParseState _ position _) ->
-        ParseState (drop (length str) input)
-                   (updatePosString position str)
-                   true
+        ParseState rest (updatePos position) true
       pure str
     _ -> fail ("Expected " <> show str)
 
--- | Match any character.
-anyChar :: forall s m. StringLike s => Monad m => ParserT s m Char
+-- | Match any token.
+anyChar :: forall f c m. StreamLike f c => Monad m => ParserT f m c
 anyChar = do
   input <- gets \(ParseState input _ _) -> input
   case uncons input of
     Nothing -> fail "Unexpected EOF"
-    Just { head, tail } -> do
+    Just ({ head, updatePos, tail }) -> do
       modify \(ParseState _ position _) ->
-        ParseState tail
-                   (updatePosString position (singleton head))
-                   true
+        ParseState tail (updatePos position) true
       pure head
 
--- | Match a character satisfying the specified predicate.
-satisfy :: forall s m. StringLike s => Monad m => (Char -> Boolean) -> ParserT s m Char
+-- | Match a token satisfying the specified predicate.
+satisfy :: forall f c m. StreamLike f c => Show c => Monad m => (c -> Boolean) -> ParserT f m c
 satisfy f = try do
   c <- anyChar
   if f c then pure c
-         else fail $ "Character '" <> singleton c <> "' did not satisfy predicate"
+         else fail $ "Character " <> show c <> " did not satisfy predicate"
 
--- | Match the specified character
-char :: forall s m. StringLike s => Monad m => Char -> ParserT s m Char
+-- | Match the specified token
+char :: forall f c m. StreamLike f c => Eq c => Show c => Monad m => c -> ParserT f m c
 char c = satisfy (_ == c) <?> show c
 
--- | Match a whitespace character.
-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
+-- | Match many whitespace character in some Unfoldable.
+whiteSpace :: forall f m g. StreamLike f Char => Unfoldable g => Monoid f => Monad m => ParserT f m (g Char)
+whiteSpace = map toUnfoldable whiteSpace'
+
+-- | Match a whitespace characters but returns them using Array.
+whiteSpace' :: forall f m. StreamLike f Char => Monad m => ParserT f m (Array Char)
+whiteSpace' = many $ satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
 
 -- | Skip whitespace characters.
-skipSpaces :: forall s m. StringLike s => Monad m => ParserT s m Unit
-skipSpaces = void whiteSpace
+skipSpaces :: forall f m. StreamLike f Char => Monad m => ParserT f m Unit
+skipSpaces = void whiteSpace'
 
--- | Match one of the characters in the array.
-oneOf :: forall s m. StringLike s => Monad m => Array Char -> ParserT s m Char
+-- | Match one of the tokens in the array.
+oneOf :: forall f c m. StreamLike f c => Show c => Eq c => Monad m => Array c -> ParserT f m c
 oneOf ss = satisfy (flip elem ss) <?> ("one of " <> show ss)
 
--- | Match any character not in the array.
-noneOf :: forall s m. StringLike s => Monad m => Array Char -> ParserT s m Char
+-- | Match any token not in the array.
+noneOf :: forall f c m. StreamLike f c => Show c => Eq c => Monad m => Array c -> ParserT f m c
 noneOf ss = satisfy (flip notElem ss) <?> ("none of " <> show ss)

src/Text/Parsing/Parser/Token.purs

@@ -1,10 +1,7 @@
 -- | Functions for working with streams of tokens.
 
 module Text.Parsing.Parser.Token
-  ( token
-  , when
-  , match
-  , LanguageDef
+  ( LanguageDef
   , GenLanguageDef(LanguageDef)
   , unGenLanguageDef
   , TokenParser
@@ -44,28 +41,6 @@ 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 = 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
-when tokpos f = try $ do
-  a <- token tokpos
-  guard $ f a
-  pure a
-
--- | Match the specified token at the head of the stream.
-match :: forall a m. Monad m => Eq a => (a -> Position) -> a -> ParserT (List a) m a
-match tokpos tok = when tokpos (_ == tok)
-
 type LanguageDef = GenLanguageDef String Identity
 
 -- | The `GenLanguageDef` type is a record that contains all parameterizable

test/Main.purs

@@ -16,8 +16,8 @@ import Text.Parsing.Parser.Combinators (endBy1, sepBy1, optionMaybe, try, chainl
 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 Text.Parsing.Parser.String (eof, string, char, satisfy, anyChar, class HasUpdatePosition)
+import Text.Parsing.Parser.Token (TokenParser, makeTokenParser)
 import Prelude hiding (between,when)
 
 parens :: forall m a. Monad m => ParserT String m a -> ParserT String m a
@@ -83,6 +83,9 @@ instance testTokensEq :: Eq TestToken where
   eq B B = true
   eq _ _ = false
 
+instance stringHasUpdatePosition :: HasUpdatePosition TestToken where
+  updatePos (Position { column, line }) tok = Position { column: column + 1, line}
+
 isA :: TestToken -> Boolean
 isA A = true
 isA _ = false
@@ -438,15 +441,14 @@ main = do
   parseTest "1*2+3/4-5" (-3) exprTest
   parseTest "ab?" "ab" manySatisfyTest
 
-  let tokpos = const initialPos
-  parseTest (fromFoldable [A, B]) A (token tokpos)
-  parseTest (fromFoldable [B, A]) B (token tokpos)
+  parseTest (fromFoldable [A, B]) A (anyChar)
+  parseTest (fromFoldable [B, A]) B (anyChar)
 
-  parseTest (fromFoldable [A, B]) A (when tokpos isA)
+  parseTest (fromFoldable [A, B]) A (satisfy isA)
 
-  parseTest (fromFoldable [A]) A (match tokpos A)
-  parseTest (fromFoldable [B]) B (match tokpos B)
-  parseTest (fromFoldable [A, B]) A (match tokpos A)
+  parseTest (fromFoldable [A]) A (char A)
+  parseTest (fromFoldable [B]) B (char B)
+  parseTest (fromFoldable [A, B]) A (char A)
 
   parseErrorTestPosition (string "abc") "bcd" (Position { column: 1, line: 1 })
   parseErrorTestPosition (string "abc" *> eof) "abcdefg" (Position { column: 4, line: 1 })