module Data.ByteString.Parse
( Parser
, Result(..)
, parse
, parseFeed
, byte
, anyByte
, bytes
, take
, takeWhile
, takeAll
, skip
, skipWhile
, skipAll
) where
import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Word
import Prelude hiding (take, takeWhile)
data Result a =
ParseFail String
| ParseMore (ByteString -> Result a)
| ParseOK ByteString a
instance Show a => Show (Result a) where
show (ParseFail err) = "ParseFailure: " ++ err
show (ParseMore _) = "ParseMore _"
show (ParseOK b a) = "ParseOK " ++ show a ++ " " ++ show b
type Failure r = ByteString -> String -> Result r
type Success a r = ByteString -> a -> Result r
newtype Parser a = Parser
{ runParser :: forall r . ByteString -> Failure r -> Success a r -> Result r }
instance Monad Parser where
fail errorMsg = Parser $ \buf err _ -> err buf ("failed: " ++ errorMsg)
return v = Parser $ \buf _ ok -> ok buf v
m >>= k = Parser $ \buf err ok ->
runParser m buf err (\buf' a -> runParser (k a) buf' err ok)
instance MonadPlus Parser where
mzero = fail "Parser.MonadPlus.mzero"
mplus f g = Parser $ \buf err ok ->
runParser f buf (\buf' _ -> runParser g buf' err ok) ok
instance Functor Parser where
fmap f p = Parser $ \buf err ok ->
runParser p buf err (\b a -> ok b (f a))
instance Applicative Parser where
pure = return
(<*>) d e = d >>= \b -> e >>= \a -> return (b a)
instance Alternative Parser where
empty = fail "Parser.Alternative.empty"
(<|>) = mplus
parseFeed :: Monad m => m B.ByteString -> Parser a -> B.ByteString -> m (Result a)
parseFeed feeder p initial = loop $ parse p initial
where loop (ParseMore k) = feeder >>= (loop . k)
loop r = return r
parse :: Parser a -> ByteString -> Result a
parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a)
getMore :: Parser ()
getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
if B.null nextChunk
then err buf "EOL: need more data"
else ok (B.append buf nextChunk) ()
getAll :: Parser ()
getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
if B.null nextChunk
then ok buf ()
else runParser getAll (B.append buf nextChunk) err ok
flushAll :: Parser ()
flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
if B.null nextChunk
then ok buf ()
else runParser getAll B.empty err ok
anyByte :: Parser Word8
anyByte = Parser $ \buf err ok ->
case B.uncons buf of
Nothing -> runParser (getMore >> anyByte) buf err ok
Just (c1,b2) -> ok b2 c1
byte :: Word8 -> Parser ()
byte w = Parser $ \buf err ok ->
case B.uncons buf of
Nothing -> runParser (getMore >> byte w) buf err ok
Just (c1,b2) | c1 == w -> ok b2 ()
| otherwise -> err buf ("byte " ++ show w ++ " : failed")
bytes :: ByteString -> Parser ()
bytes allExpected = consumeEq allExpected
where errMsg = "bytes " ++ show allExpected ++ " : failed"
consumeEq expected = Parser $ \actual err ok ->
let eLen = B.length expected in
if B.length actual >= eLen
then
let (aMatch,aRem) = B.splitAt eLen actual
in if aMatch == expected
then ok aRem ()
else err actual errMsg
else
let (eMatch, eRem) = B.splitAt (B.length actual) expected
in if actual == eMatch
then runParser (getMore >> consumeEq eRem) B.empty err ok
else err actual errMsg
take :: Int -> Parser ByteString
take n = Parser $ \buf err ok ->
if B.length buf >= n
then let (b1,b2) = B.splitAt n buf in ok b2 b1
else runParser (getMore >> take n) buf err ok
takeWhile :: (Word8 -> Bool) -> Parser ByteString
takeWhile predicate = Parser $ \buf err ok ->
case B.span predicate buf of
(_, "") -> runParser (getMore >> takeWhile predicate) buf err ok
(b1, b2) -> ok b2 b1
takeAll :: Parser ByteString
takeAll = Parser $ \buf err ok ->
runParser (getAll >> returnBuffer) buf err ok
where
returnBuffer = Parser $ \buf _ ok -> ok B.empty buf
skip :: Int -> Parser ()
skip n = Parser $ \buf err ok ->
if B.length buf >= n
then ok (B.drop n buf) ()
else runParser (getMore >> skip (n B.length buf)) B.empty err ok
skipWhile :: (Word8 -> Bool) -> Parser ()
skipWhile p = Parser $ \buf err ok ->
case B.span p buf of
(_, "") -> runParser (getMore >> skipWhile p) B.empty err ok
(_, b2) -> ok b2 ()
skipAll :: Parser ()
skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok