Generalize StringLike to StreamLike fix #58

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,127 @@
 
 module Text.Parsing.Parser.String where
 
+
+import Control.Monad.Rec.Class (tailRecM3, Step(..))
 import Data.String as S
 import Control.Monad.State (modify, gets)
-import Data.Array (many)
-import Data.Foldable (elem, notElem)
+import Data.Array (many, toUnfoldable)
+import Data.Foldable (elem, notElem, foldMap)
+import Data.Unfoldable (class Unfoldable)
+import Data.List as L
 import Data.Maybe (Maybe(..))
-import Data.Newtype (wrap)
-import Data.String (Pattern, fromCharArray, length, singleton)
+import Data.Either (Either(..))
+import Data.Monoid (class Monoid)
 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)
+import Data.Foldable (foldl)
+
+-- | A newtype used in cases where there is a prefix string to droped.
+newtype Prefix f = Prefix f
+
+derive instance eqPrefix :: Eq f => Eq (Prefix f)
+derive instance ordPrefix :: Ord f => Ord (Prefix f)
+-- derive instance newtypePrefix :: Newtype Prefix _
+
+instance showPrefix :: Show f => Show (Prefix f) 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 stringLikeString :: StreamLike String Char where
+  uncons f = S.uncons f <#> \({ head, tail}) ->
+    { head: head, updatePos: (_ `updatePos` head), tail}
+  drop (Prefix p) s = S.stripPrefix (S.Pattern p) s <#> \rest ->
+    { rest: rest, updatePos: (_ `updatePos` p)}
+
+instance listcharLikeString :: (Eq a, HasUpdatePosition a) => StreamLike (L.List a) a where
+  uncons f = L.uncons f <#> \({ head, tail}) ->
+    { head: head, updatePos: (_ `updatePos` head), tail}
+  drop (Prefix p') s' = case (tailRecM3 go p' s' id) of -- no MonadRec for Maybe
+      Right a -> pure a
+      _ -> Nothing
+    where
+    go prefix input updatePos' = case prefix, input of
+      (L.Cons p ps), (L.Cons i is) | p == i -> pure $ Loop
+        ({ a: ps, b: is, c: updatePos' >>> (_ `updatePos` p) })
+      (L.Nil), is -> pure $ Done
+        ({ rest: is, updatePos: updatePos' })
+      _, _ -> Left unit
+
+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 :: 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
+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
+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
+char :: forall f c m. StreamLike f c => Eq c => Show c => Monad m => c -> ParserT f m c
 char c = satisfy (_ == c) <?> ("Expected " <> 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 characters.
+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 as 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
-oneOf ss = satisfy (flip elem ss) <?> ("Expected one of " <> show ss)
+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
-noneOf ss = satisfy (flip notElem ss) <?> ("Expected none of " <> show ss)
+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)