Internal.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE RankNTypes         #-}

-- | This module provides internal utilities and it is likely
-- to be modified in backwards-incompatible ways in the future.
--
-- Use the stable API exported by the "Pipes.Aeson" module instead.
module Pipes.Aeson.Internal
  ( DecodingError(..)
  , consecutively
  , decodeL
  ) where
import           Control.Exception                (Exception)
import           Control.Monad.Trans.Error        (Error)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.Aeson                       as Ae
import qualified Data.Attoparsec.Types            as Attoparsec
import qualified Data.ByteString                  as B
import qualified Data.ByteString.Internal         as B (isSpaceWord8)
import           Data.Data                        (Data, Typeable)
import           Pipes
import qualified Pipes.Attoparsec                 as PA
import qualified Pipes.Parse                      as Pipes

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

-- | An error while decoding a JSON value.
data DecodingError
  = AttoparsecError PA.ParsingError
    -- ^An @attoparsec@ error that happened while parsing the raw JSON string.
  | FromJSONError String
    -- ^An @aeson@ error that happened while trying to convert a
    -- 'Data.Aeson.Value' to an 'A.FromJSON' instance, as reported by
    -- 'Data.Aeson.Error'.
  deriving (Show, Eq, Data, Typeable)

instance Exception DecodingError
instance Error     DecodingError

-- | This instance allows using 'Pipes.Lift.errorP' with 'Pipes.Aeson.decoded'
-- and 'Pipes.Aeson.decodedL'
instance Error (DecodingError, Producer a m r)

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

-- | Consecutively parse 'a' elements from the given 'Producer' using the given
-- parser (such as 'Pipes.Aeson.decode' or 'Pipes.Aeson.parseValue'), skipping
-- any leading whitespace each time.
--
-- This 'Producer' runs until it either runs out of input or until a decoding
-- failure occurs, in which case it returns 'Left' with a 'DecodingError' and
-- a 'Producer' with any leftovers. You can use 'Pipes.Lift.errorP' to turn the
-- 'Either' return value into an 'Control.Monad.Trans.Error.ErrorT'
-- monad transformer.
consecutively
  :: (Monad m)
  => Pipes.Parser B.ByteString m (Maybe (Either e a))
  -> Producer B.ByteString m r  -- ^Producer from which to draw raw input.
  -> Producer a m (Either (e, Producer B.ByteString m r) r)
consecutively parser = step where
    step p0 = do
      x <- lift $ nextSkipBlank p0
      case x of
         Left r -> return (Right r)
         Right (bs, p1) -> do
            (mea, p2) <- lift $ S.runStateT parser (yield bs >> p1)
            case mea of
               Just (Right a) -> yield a >> step p2
               Just (Left  e) -> return (Left (e, p2))
               Nothing -> error "Pipes.Aeson.Internal.consecutively: impossible"
{-# INLINABLE consecutively #-}


-- | Decodes a 'Ae.FromJSON' value from the underlying state using the given
-- 'Attoparsec.Parser' in order to obtain an 'Ae.Value' first.
--
-- Returns either the decoded entitiy, or a 'I.DecodingError' in case of error.
--
-- It returns 'Nothing' if the underlying 'Producer' is exhausted, otherwise
-- it returns either the decoded entity or a 'I.DecodingError' in case of error.
decodeL
  :: (Monad m, Ae.FromJSON a)
  => Attoparsec.Parser B.ByteString Ae.Value
  -> Pipes.Parser B.ByteString m (Maybe (Either DecodingError (Int, a))) -- ^
decodeL parser = do
    mev <- PA.parseL parser
    return $ case mev of
       Nothing             -> Nothing
       Just (Left l)       -> Just (Left (AttoparsecError l))
       Just (Right (n, v)) -> case Ae.fromJSON v of
          Ae.Error e   -> Just (Left (FromJSONError e))
          Ae.Success a -> Just (Right (n, a))
{-# INLINABLE decodeL #-}


--------------------------------------------------------------------------------
-- Internal stuff

-- | Like 'Pipes.next', except it skips leading whitespace and 'B.null' chunks.
nextSkipBlank
  :: (Monad m)
  => Producer B.ByteString m r
  -> m (Either r (B.ByteString, Producer B.ByteString m r))
nextSkipBlank = go where
    go p0 = do
      x <- next p0
      case x of
         Left  _      -> return x
         Right (a,p1) -> do
            let a' = B.dropWhile B.isSpaceWord8 a
            if B.null a' then go p1
                         else return (Right (a', p1))
{-# INLINABLE nextSkipBlank #-}