-- |
-- Module      : Data.ByteArray.Pack.Internal
-- License     : BSD-Style
-- Copyright   : Copyright © 2014 Nicolas DI PRIMA
--
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Data.ByteArray.Pack.Internal
    ( Result(..)
    , Packer(..)
    , actionPacker
    , actionPackerWithRemain
    ) where

import           Foreign.Ptr (Ptr)
import           Data.ByteArray.MemView
import           Data.Memory.Internal.Imports

-- | Packing result:
--
-- * PackerMore: the next state of Packing with an arbitrary value
-- * PackerFail: an error happened
data Result a =
      PackerMore a MemView
    | PackerFail String
    deriving (Int -> Result a -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show)

-- | Simple ByteArray Packer
newtype Packer a = Packer { forall a. Packer a -> MemView -> IO (Result a)
runPacker_ :: MemView -> IO (Result a) }

instance Functor Packer where
    fmap :: forall a b. (a -> b) -> Packer a -> Packer b
fmap = forall a b. (a -> b) -> Packer a -> Packer b
fmapPacker

instance Applicative Packer where
    pure :: forall a. a -> Packer a
pure  = forall a. a -> Packer a
returnPacker
    <*> :: forall a b. Packer (a -> b) -> Packer a -> Packer b
(<*>) = forall a b. Packer (a -> b) -> Packer a -> Packer b
appendPacker

instance Monad Packer where
    return :: forall a. a -> Packer a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    >>= :: forall a b. Packer a -> (a -> Packer b) -> Packer b
(>>=)  = forall a b. Packer a -> (a -> Packer b) -> Packer b
bindPacker

fmapPacker :: (a -> b) -> Packer a -> Packer b
fmapPacker :: forall a b. (a -> b) -> Packer a -> Packer b
fmapPacker a -> b
f Packer a
p = forall a. (MemView -> IO (Result a)) -> Packer a
Packer forall a b. (a -> b) -> a -> b
$ \MemView
cache -> do
    Result a
rv <- forall a. Packer a -> MemView -> IO (Result a)
runPacker_ Packer a
p MemView
cache
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Result a
rv of
        PackerMore a
v MemView
cache' -> forall a. a -> MemView -> Result a
PackerMore (a -> b
f a
v) MemView
cache'
        PackerFail String
err      -> forall a. String -> Result a
PackerFail String
err
{-# INLINE fmapPacker #-}

returnPacker :: a -> Packer a
returnPacker :: forall a. a -> Packer a
returnPacker a
v = forall a. (MemView -> IO (Result a)) -> Packer a
Packer forall a b. (a -> b) -> a -> b
$ \MemView
cache -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> MemView -> Result a
PackerMore a
v MemView
cache
{-# INLINE returnPacker #-}

bindPacker :: Packer a -> (a -> Packer b) -> Packer b
bindPacker :: forall a b. Packer a -> (a -> Packer b) -> Packer b
bindPacker Packer a
p a -> Packer b
fp = forall a. (MemView -> IO (Result a)) -> Packer a
Packer forall a b. (a -> b) -> a -> b
$ \MemView
cache -> do
    Result a
rv <- forall a. Packer a -> MemView -> IO (Result a)
runPacker_ Packer a
p MemView
cache
    case Result a
rv of
        PackerMore a
v MemView
cache' -> forall a. Packer a -> MemView -> IO (Result a)
runPacker_ (a -> Packer b
fp a
v) MemView
cache'
        PackerFail String
err      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> Result a
PackerFail String
err
{-# INLINE bindPacker #-}

appendPacker :: Packer (a -> b) -> Packer a -> Packer b
appendPacker :: forall a b. Packer (a -> b) -> Packer a -> Packer b
appendPacker Packer (a -> b)
p1f Packer a
p2 = Packer (a -> b)
p1f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
p1 -> Packer a
p2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
p1 a
v)
{-# INLINE appendPacker #-}

-- | run a sized action
actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a
actionPacker :: forall a. Int -> (Ptr Word8 -> IO a) -> Packer a
actionPacker Int
s Ptr Word8 -> IO a
action = forall a. (MemView -> IO (Result a)) -> Packer a
Packer forall a b. (a -> b) -> a -> b
$ \m :: MemView
m@(MemView Ptr Word8
ptr Int
size) ->
    case forall a. Ord a => a -> a -> Ordering
compare Int
size Int
s of
        Ordering
LT -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> Result a
PackerFail String
"Not enough space in destination"
        Ordering
_  -> do
            a
v <- Ptr Word8 -> IO a
action Ptr Word8
ptr
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> MemView -> Result a
PackerMore a
v (MemView
m MemView -> Int -> MemView
`memViewPlus` Int
s)
{-# INLINE actionPacker #-}

-- | run a sized action
actionPackerWithRemain :: Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a
actionPackerWithRemain :: forall a. Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a
actionPackerWithRemain Int
s Ptr Word8 -> Int -> IO (Int, a)
action = forall a. (MemView -> IO (Result a)) -> Packer a
Packer forall a b. (a -> b) -> a -> b
$ \m :: MemView
m@(MemView Ptr Word8
ptr Int
size) ->
    case forall a. Ord a => a -> a -> Ordering
compare Int
size Int
s of
        Ordering
LT -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> Result a
PackerFail String
"Not enough space in destination"
        Ordering
_  -> do
            (Int
remain, a
v) <- Ptr Word8 -> Int -> IO (Int, a)
action Ptr Word8
ptr Int
size
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
remain forall a. Ord a => a -> a -> Bool
> Int
s
                then forall a. String -> Result a
PackerFail String
"remaining bytes higher than the destination's size"
                else forall a. a -> MemView -> Result a
PackerMore a
v (MemView
m MemView -> Int -> MemView
`memViewPlus` (Int
sforall a. Num a => a -> a -> a
+Int
remain))
{-# INLINE actionPackerWithRemain #-}