Parser.hs

-- | A custom parsing monad, optimized for speed.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.ProtoLens.Encoding.Parser
    ( Parser
    , runParser
    , atEnd
    , isolate
    , getWord8
    , getWord32le
    , getBytes
    , getText
    , (<?>)
    ) where

import Data.Bits (shiftL, (.|.))
import Data.Word (Word8, Word32)
import Data.ByteString (ByteString, packCStringLen)
import qualified Data.ByteString.Unsafe as B
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe (unsafePerformIO)

import Data.ProtoLens.Encoding.Parser.Internal

-- | Evaluates a parser on the given input.
--
-- If the parser does not consume all of the input, the rest of the
-- input is discarded and the parser still succeeds.  Parsers may use
-- 'atEnd' to detect whether they are at the end of the input.
--
-- Values returned from actions in this monad will not hold onto the original
-- ByteString, but rather make immutable copies of subsets of its bytes.
runParser :: Parser a -> ByteString -> Either String a
runParser (Parser m) b =
    case unsafePerformIO $ B.unsafeUseAsCStringLen b
            $ \(p, len) -> m (p `plusPtr` len) (castPtr p) of
        ParseSuccess _ x -> Right x
        ParseFailure s -> Left s

-- | Returns True if there is no more input left to consume.
atEnd :: Parser Bool
atEnd = Parser $ \end pos -> return $ ParseSuccess pos (pos == end)

-- | Parse a one-byte word.
getWord8 :: Parser Word8
getWord8 = withSized 1 "getWord8: Unexpected end of input" peek

-- | Parser a 4-byte word in little-endian order.
getWord32le :: Parser Word32
getWord32le = withSized 4 "getWord32le: Unexpected end of input" $ \pos -> do
    b1 <- fromIntegral <$> peek pos
    b2 <- fromIntegral <$> peek (pos `plusPtr'` 1)
    b3 <- fromIntegral <$> peek (pos `plusPtr'` 2)
    b4 <- fromIntegral <$> peek (pos `plusPtr'` 3)
    let f b b' = b `shiftL` 8 .|. b'
    return $! f (f (f b4 b3) b2) b1

-- | Parse a sequence of zero or more bytes of the given length.
--
-- The new ByteString is an immutable copy of the bytes in the input
-- and will be managed separately on the Haskell heap from the original
-- input 'ByteString'.
--
-- Fails the parse if given a negative length.
getBytes :: Int -> Parser ByteString
getBytes n = withSized n "getBytes: Unexpected end of input"
                    $ \pos -> packCStringLen (castPtr pos, n)

getText :: Int -> Parser Text
getText n = do
  r <- withSized n "getText: Unexpected end of input" $ \pos ->
          decodeUtf8' <$> B.unsafePackCStringLen (castPtr pos, n)
  either (fail . show) pure r

-- | Helper function for reading bytes from the current position and
-- advancing the pointer.
--
-- Fails the parse if given a negative length.  (GHC will elide the check
-- if the length is a nonnegative constant.)
--
-- It is only safe for @f@ to peek between its argument @p@ and
-- @p `plusPtr` (len - 1)@, inclusive.
withSized :: Int -> String -> (Ptr Word8 -> IO a) -> Parser a
withSized len message f
    | len >= 0 = Parser $ \end pos ->
        let pos' = pos `plusPtr'` len
        in if pos' > end
            then return $ ParseFailure message
            else ParseSuccess pos' <$> f pos
    | otherwise = fail "withSized: negative length"
{-# INLINE withSized #-}

-- | Run the given parsing action as if there are only
-- @len@ bytes remaining.  That is, once @len@ bytes have been
-- consumed, 'atEnd' will return 'True' and other actions
-- like 'getWord8' will act like there is no input remaining.
--
-- Fails the parse if given a negative length.
isolate :: Int -> Parser a -> Parser a
isolate len (Parser m)
    | len >= 0 = Parser $ \end pos ->
        let end' = pos `plusPtr` len
        in if end' > end
            then return $ ParseFailure "isolate: unexpected end of input"
            else m end' pos
    | otherwise = fail "isolate: negative length"

-- | If the parser fails, prepend an error message.
(<?>) :: Parser a -> String -> Parser a
Parser m <?> msg = Parser $ \end p -> wrap <$> m end p
  where
    wrap (ParseFailure s) = ParseFailure (msg ++ ": " ++ s)
    wrap r = r

-- | Advance a pointer.  Unlike 'plusPtr', preserves the type of the input.
plusPtr' :: Ptr a -> Int -> Ptr a
plusPtr' = plusPtr