-- |
-- 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
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
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 { Packer a -> MemView -> IO (Result a)
runPacker_ :: MemView -> IO (Result a) }

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

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

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

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

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

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