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.Stream (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,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 }

src/Text/Parsing/Parser/Stream.purs

@@ -0,0 +1,113 @@
+-- | Primitive parsers for working with an `StreamLike` input.
+
+module Text.Parsing.Parser.Stream where
+
+import Control.Monad.State (modify, gets)
+import Control.Monad.Trans.Class (lift)
+import Data.Foldable (fold, 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.String as S
+import Prelude hiding (between)
+import Text.Parsing.Parser (ParseState(..), ParserT, fail)
+import Text.Parsing.Parser.Combinators (try, (<?>))
+import Text.Parsing.Parser.Pos (Position, updatePosString, updatePosChar)
+
+-- | A newtype used to identify a prefix of a stream
+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.
+-- |
+-- | Instances must satisfy the following laws:
+-- | - `stripPrefix (Prefix a) a >>= uncons = Nothing`
+class StreamLike 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 })
+
+instance stringStreamLike :: (Applicative m) =>  StreamLike 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 listStreamLike :: (Applicative m, Eq a, HasUpdatePosition a) => StreamLike (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)))}
+
+instance lazyListStreamLike :: (Applicative m, Eq a, HasUpdatePosition a) => StreamLike (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)))}
+
+-- | Match end of stream.
+eof :: forall s t m. StreamLike s m t => Monad m => ParserT s m Unit
+eof = do
+  input <- gets \(ParseState input _ _) -> input
+  (lift $ uncons input) >>= case _ of
+    Nothing -> pure unit
+    _ -> fail "Expected EOF"
+
+-- | Match the specified prefix.
+prefix :: forall f c m. StreamLike 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
+      pure p
+    _ -> fail ("Expected " <> show p)
+
+-- | Match any token.
+token :: forall s t m. StreamLike s m t => Monad m => ParserT s m t
+token = do
+  input <- gets \(ParseState input _ _) -> input
+  (lift $ uncons input) >>= case _ of
+    Nothing -> fail "Unexpected EOF"
+    Just ({ head, updatePos, tail }) -> do
+      modify \(ParseState _ position _) ->
+        ParseState tail (updatePos position) true
+      pure head
+
+-- | Match a token satisfying the specified predicate.
+satisfy :: forall s t m. StreamLike s m t => Show t => Monad m => (t -> Boolean) -> ParserT s m t
+satisfy f = try do
+  c <- token
+  if f c then pure c
+         else fail $ "Character " <> show c <> " did not satisfy predicate"
+
+-- | Match the specified token
+match :: forall s t m. StreamLike s m t => Eq t => Show t => Monad m => t -> ParserT s m t
+match c = satisfy (_ == c) <?> show c
+
+
+-- | Match one of the tokens in the array.
+oneOf :: forall s t m. StreamLike s m t => Show t => Eq t => Monad m => Array t -> ParserT s m t
+oneOf ss = satisfy (flip elem ss) <?> ("one of " <> show ss)
+
+-- | Match any token not in the array.
+noneOf :: forall s t m. StreamLike s m t => Show t => Eq t => Monad m => Array t -> ParserT s m t
+noneOf ss = satisfy (flip notElem ss) <?> ("none of " <> show ss)

src/Text/Parsing/Parser/String.purs

@@ -2,89 +2,46 @@
 
 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.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 Data.Char.Unicode (isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit, isSpace, isUpper)
 import Prelude hiding (between)
+import Text.Parsing.Parser (ParserT)
+import Text.Parsing.Parser.Combinators ((<?>))
+import Text.Parsing.Parser.Stream (class StreamLike, satisfy)
 
--- | 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 }
+-- | Match a whitespace characters but returns them using Array.
+whiteSpace :: forall s m. StreamLike s m Char => Monad m => ParserT s m (Array Char)
+whiteSpace = many space
 
-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
-eof = do
-  input <- gets \(ParseState input _ _) -> input
-  unless (null input) (fail "Expected EOF")
-
--- | Match the specified string.
-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)
+-- | Skip whitespace characters.
+skipSpaces :: forall s m. StreamLike s m Char => Monad m => ParserT s m Unit
+skipSpaces = void whiteSpace
 
--- | Match any character.
-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
+-- | Parse a digit.  Matches any char that satisfies `Data.Char.Unicode.isDigit`.
+digit :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+digit = satisfy isDigit <?> "digit"
 
--- | Match a character satisfying the specified predicate.
-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"
+-- | Parse a hex digit.  Matches any char that satisfies `Data.Char.Unicode.isHexDigit`.
+hexDigit :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+hexDigit = satisfy isHexDigit <?> "hex digit"
 
--- | Match the specified character
-char :: forall s m. StringLike s => Monad m => Char -> ParserT s m Char
-char c = satisfy (_ == c) <?> show c
+-- | Parse an octal digit.  Matches any char that satisfies `Data.Char.Unicode.isOctDigit`.
+octDigit :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+octDigit = satisfy isOctDigit <?> "oct digit"
 
--- | 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
+-- | Parse an uppercase letter.  Matches any char that satisfies `Data.Char.Unicode.isUpper`.
+upper :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+upper = satisfy isUpper <?> "uppercase letter"
 
--- | Skip whitespace characters.
-skipSpaces :: forall s m. StringLike s => Monad m => ParserT s m Unit
-skipSpaces = void whiteSpace
+-- | Parse a space character.  Matches any char that satisfies `Data.Char.Unicode.isSpace`.
+space :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+space = satisfy isSpace <?> "space"
 
--- | Match one of the characters in the array.
-oneOf :: forall s m. StringLike s => Monad m => Array Char -> ParserT s m Char
-oneOf ss = satisfy (flip elem ss) <?> ("one of " <> show ss)
+-- | Parse an alphabetical character.  Matches any char that satisfies `Data.Char.Unicode.isAlpha`.
+letter :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+letter = satisfy isAlpha <?> "letter"
 
--- | Match any character not in the array.
-noneOf :: forall s m. StringLike s => Monad m => Array Char -> ParserT s m Char
-noneOf ss = satisfy (flip notElem ss) <?> ("none of " <> show ss)
+-- | Parse an alphabetical or numerical character.
+-- | Matches any char that satisfies `Data.Char.Unicode.isAlphaNum`.
+alphaNum :: forall s m . StreamLike s m Char => Monad m => ParserT s m Char
+alphaNum = satisfy isAlphaNum <?> "letter or digit"