module Data.ByteArray.Pack.Internal
( Result(..)
, Packer(..)
, actionPacker
, actionPackerWithRemain
) where
import Foreign.Ptr (Ptr)
import Data.ByteArray.MemView
import Data.Memory.Internal.Imports
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)
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 #-}
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 #-}
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 #-}