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

@@ -15,7 +15,7 @@
 -- | 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
@@ -49,7 +49,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
@@ -85,7 +85,7 @@ lookAhead p = (ParserT <<< ExceptT <<< StateT) \s -> do
 -- | 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 +122,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

@@ -62,7 +62,7 @@ import Data.Maybe (Maybe(..))
 import Text.Parsing.Parser (ParserT, ParseState(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.String (prefix, oneOf)
 
 -- | Indentation sensitive parser type. Usually @ m @ will
 -- | be @ Identity @ as with any @ ParserT @
@@ -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,7 +12,7 @@ import Prelude
 
 import Control.Alt ((<|>))
 import Text.Parsing.Parser (ParserT)
-import Text.Parsing.Parser.String (char, oneOf)
+import Text.Parsing.Parser.String (match, oneOf)
 import Text.Parsing.Parser.Token (LanguageDef, TokenParser, GenLanguageDef(..), unGenLanguageDef, makeTokenParser, alphaNum, letter)
 
 -----------------------------------------------------------
@@ -70,7 +70,7 @@ emptyDef = LanguageDef
             , commentEnd:      ""
             , commentLine:     ""
             , nestedComments:  true
-            , identStart:      letter <|> char '_'
+            , identStart:      letter <|> match '_'
             , identLetter:     alphaNum <|> oneOf ['_', '\'']
             , opStart:         op'
             , opLetter:        op'
@@ -95,7 +95,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 }

src/Text/Parsing/Parser/String.purs

@@ -2,89 +2,113 @@
 
 module Text.Parsing.Parser.String where
 
-import Data.String as S
-import Control.Monad.State (modify, gets)
 import Data.Array (many)
-import Data.Foldable (elem, notElem)
+import Data.Foldable (fold, elem, notElem)
+import Data.List as L
+import Data.Monoid.Endo (Endo(..))
 import Data.Maybe (Maybe(..))
-import Data.Newtype (wrap)
-import Data.String (Pattern, fromCharArray, length, singleton)
+import Data.Newtype (class Newtype, unwrap)
+import Data.String as S
+import Control.Monad.State (modify, gets)
 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 stripPrefixed.
+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:
+-- | - `stripPrefix (Prefix a) a >>= uncons = Nothing`
+class StreamLike f c | f -> c where
+  uncons :: f -> Maybe { head :: c, tail :: f, updatePos :: Position -> Position }
+  stripPrefix :: 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)}
+  stripPrefix (Prefix p) s = S.stripPrefix (S.Pattern p) s <#> \rest ->
+    { rest, updatePos: (_ `updatePos` p)}
+
+instance listStreamLike :: (Eq a, HasUpdatePosition a) => StreamLike (L.List a) a where
+  uncons f = L.uncons f <#> \({ head, tail}) ->
+    { head, tail, updatePos: (_ `updatePos` head)}
+  stripPrefix (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
-string str = do
+-- | Match the specified prefix.
+prefix :: forall f c m. StreamLike f c => Show f => Monad m => f -> ParserT f m f
+prefix str = do
   input <- gets \(ParseState input _ _) -> input
-  case indexOf (wrap str) input of
-    Just 0 -> do
+  case stripPrefix (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
-anyChar = do
+-- | Match any token.
+token :: forall f c m. StreamLike f c => Monad m => ParserT f m c
+token = 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
+  c <- token
   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 token
+match :: forall f c m. StreamLike f c => Eq c => Show c => Monad m => c -> ParserT f m c
+match c = satisfy (_ == c) <?> show c
 
--- | Match the specified character
-char :: forall s m. StringLike s => Monad m => Char -> ParserT s m Char
-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 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 == ' ' || c == '\n' || c == '\t' || c == '\r'
 
 -- | Skip whitespace characters.
-skipSpaces :: forall s m. StringLike s => Monad m => ParserT s m Unit
+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)