Internal.hs

{-# LANGUAGE DeriveDataTypeable #-}

-- | This module provides low-level integration with the @binary@ package and is
-- likely to be modified in backwards-incompatible ways in the future.
--
-- Use the "Control.Proxy.Binary" module instead.

module Control.Proxy.Binary.Internal
  ( DecodingError(..)
  , parseWith
  ) where

-------------------------------------------------------------------------------

import qualified Data.ByteString              as BS
import qualified Data.Binary                  as Bin
import qualified Data.Binary.Get              as Bin
import Control.Exception                      (Exception)
import Data.Data                              (Data, Typeable)

-------------------------------------------------------------------------------

data DecodingError = DecodingError
  { peConsumed :: Bin.ByteOffset -- ^Number of bytes consumed before the error.
  , peMessage  :: String         -- ^Error message.
  } deriving (Show, Eq, Data, Typeable)

instance Exception DecodingError

-------------------------------------------------------------------------------

-- | Run a parser drawing input from the given monadic action as needed.
parseWith
  :: (Monad m, Bin.Binary r)
  => m (Maybe BS.ByteString)
  -- ^An action that will be executed to provide the parser with more input
  -- as needed. If the action returns 'Nothing', then it's assumed no more
  -- input is available.
  -> Bin.Get r
  -- ^Parser to run on the given input.
  -> m (Either DecodingError r, Maybe BS.ByteString)
  -- ^Either a parser error or a parsed result, together with any leftover.
parseWith refill g = step $ Bin.runGetIncremental g
  where
    step (Bin.Partial k)   = step . k =<< refill
    step (Bin.Done lo _ r) = return (Right r, mayInput lo)
    step (Bin.Fail lo n m) = return (Left (DecodingError n m), mayInput lo)
{-# INLINABLE parseWith #-}

-- | Wrap @a@ in 'Just' if not-null. Otherwise, 'Nothing'.
mayInput :: BS.ByteString -> Maybe BS.ByteString
mayInput x | BS.null x = Nothing
           | otherwise = Just x
{-# INLINE mayInput #-}