{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}

module Data.Store.Core
    ( -- * Core Types
      Poke(..), PokeException(..), pokeException
    , Peek(..), PeekResult(..), PeekException(..), peekException, tooManyBytes
    , PokeState, pokeStatePtr
    , PeekState, peekStateEndPtr
    , Offset
      -- * Encode ByteString
    , unsafeEncodeWith
      -- * Decode ByteString
    , decodeWith
    , decodeExWith, decodeExPortionWith
    , decodeIOWith, decodeIOPortionWith
    , decodeIOWithFromPtr, decodeIOPortionWithFromPtr
      -- * Storable
    , pokeStorable, peekStorable, peekStorableTy
      -- * ForeignPtr
    , pokeFromForeignPtr, peekToPlainForeignPtr, pokeFromPtr
      -- * ByteArray
    , pokeFromByteArray, peekToByteArray
      -- * Creation of PokeState / PeekState
    , unsafeMakePokeState, unsafeMakePeekState, maybeAlignmentBufferSize
    ) where

import           Control.Applicative
import           Control.Exception (Exception(..), throwIO, try)
import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Primitive (PrimMonad (..))
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import           Data.Monoid ((<>))
import           Data.Primitive.ByteArray (ByteArray, MutableByteArray(..), newByteArray, unsafeFreezeByteArray)
import qualified Data.Text as T
import           Data.Typeable
import           Data.Word
import           Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr)
import           Foreign.Ptr
import           Foreign.Storable as Storable
import           GHC.Exts (unsafeCoerce#)
import           GHC.Prim (RealWorld, ByteArray#, copyByteArrayToAddr#, copyAddrToByteArray#)
import           GHC.Ptr (Ptr(..))
import           GHC.Types (IO(..), Int(..))
import           Prelude
import           System.IO.Unsafe (unsafePerformIO)

#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif

#if ALIGNED_MEMORY
import           Foreign.Marshal.Alloc (allocaBytesAligned)
#endif

------------------------------------------------------------------------
-- Helpful Type Synonyms

-- | How far into the given Ptr to look
type Offset = Int

------------------------------------------------------------------------
-- Poke monad

-- | 'Poke' actions are useful for building sequential serializers.
--
-- They are actions which write values to bytes into memory specified by
-- a 'Ptr' base. The 'Applicative' and 'Monad' instances make it easy to
-- write serializations, by keeping track of the 'Offset' of the current
-- byte. They allow you to chain 'Poke' action such that subsequent
-- 'Poke's write into subsequent portions of the output.
newtype Poke a = Poke
    { Poke a -> PokeState -> Offset -> IO (Offset, a)
runPoke :: PokeState -> Offset -> IO (Offset, a)
      -- ^ Run the 'Poke' action, with the 'Ptr' to the buffer where
      -- data is poked, and the current 'Offset'. The result is the new
      -- offset, along with a return value.
      --
      -- May throw a 'PokeException', though this should be avoided when
      -- possible.  They usually indicate a programming error.
    }
    deriving a -> Poke b -> Poke a
(a -> b) -> Poke a -> Poke b
(forall a b. (a -> b) -> Poke a -> Poke b)
-> (forall a b. a -> Poke b -> Poke a) -> Functor Poke
forall a b. a -> Poke b -> Poke a
forall a b. (a -> b) -> Poke a -> Poke b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Poke b -> Poke a
$c<$ :: forall a b. a -> Poke b -> Poke a
fmap :: (a -> b) -> Poke a -> Poke b
$cfmap :: forall a b. (a -> b) -> Poke a -> Poke b
Functor

instance Applicative Poke where
    pure :: a -> Poke a
pure a
x = (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, a)) -> Poke a)
-> (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a b. (a -> b) -> a -> b
$ \PokeState
_ptr Offset
offset -> (Offset, a) -> IO (Offset, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Offset
offset, a
x)
    {-# INLINE pure #-}
    Poke PokeState -> Offset -> IO (Offset, a -> b)
f <*> :: Poke (a -> b) -> Poke a -> Poke b
<*> Poke PokeState -> Offset -> IO (Offset, a)
g = (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, b)) -> Poke b)
-> (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a b. (a -> b) -> a -> b
$ \PokeState
ptr Offset
offset1 -> do
        (Offset
offset2, a -> b
f') <- PokeState -> Offset -> IO (Offset, a -> b)
f PokeState
ptr Offset
offset1
        (Offset
offset3, a
g') <- PokeState -> Offset -> IO (Offset, a)
g PokeState
ptr Offset
offset2
        (Offset, b) -> IO (Offset, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset
offset3, a -> b
f' a
g')
    {-# INLINE (<*>) #-}
    Poke PokeState -> Offset -> IO (Offset, a)
f *> :: Poke a -> Poke b -> Poke b
*> Poke PokeState -> Offset -> IO (Offset, b)
g = (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, b)) -> Poke b)
-> (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a b. (a -> b) -> a -> b
$ \PokeState
ptr Offset
offset1 -> do
        (Offset
offset2, a
_) <- PokeState -> Offset -> IO (Offset, a)
f PokeState
ptr Offset
offset1
        PokeState -> Offset -> IO (Offset, b)
g PokeState
ptr Offset
offset2
    {-# INLINE (*>) #-}

instance Monad Poke where
    return :: a -> Poke a
return = a -> Poke a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}
    >> :: Poke a -> Poke b -> Poke b
(>>) = Poke a -> Poke b -> Poke b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}
    Poke PokeState -> Offset -> IO (Offset, a)
x >>= :: Poke a -> (a -> Poke b) -> Poke b
>>= a -> Poke b
f = (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, b)) -> Poke b)
-> (PokeState -> Offset -> IO (Offset, b)) -> Poke b
forall a b. (a -> b) -> a -> b
$ \PokeState
ptr Offset
offset1 -> do
        (Offset
offset2, a
x') <- PokeState -> Offset -> IO (Offset, a)
x PokeState
ptr Offset
offset1
        Poke b -> PokeState -> Offset -> IO (Offset, b)
forall a. Poke a -> PokeState -> Offset -> IO (Offset, a)
runPoke (a -> Poke b
f a
x') PokeState
ptr Offset
offset2
    {-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
    fail = pokeException . T.pack
    {-# INLINE fail #-}
#endif

#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail Poke where
    fail :: String -> Poke a
fail = Text -> Poke a
forall a. Text -> Poke a
pokeException (Text -> Poke a) -> (String -> Text) -> String -> Poke a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    {-# INLINE fail #-}
#endif

instance MonadIO Poke where
    liftIO :: IO a -> Poke a
liftIO IO a
f = (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, a)) -> Poke a)
-> (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a b. (a -> b) -> a -> b
$ \PokeState
_ Offset
offset -> (Offset
offset, ) (a -> (Offset, a)) -> IO a -> IO (Offset, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f
    {-# INLINE liftIO #-}

-- | Holds a 'pokeStatePtr', which is passed in to each 'Poke' action.
-- If the package is built with the 'force-alignment' flag, this also
-- has a hidden 'Ptr' field, which is used as scratch space during
-- unaligned writes.
#if ALIGNED_MEMORY
data PokeState = PokeState
    { pokeStatePtr :: {-# UNPACK #-} !(Ptr Word8)
    , pokeStateAlignPtr :: {-# UNPACK #-} !(Ptr Word8)
    }
#else
newtype PokeState = PokeState
    { PokeState -> Ptr Word8
pokeStatePtr :: Ptr Word8
    }
#endif

-- | Make a 'PokeState' from a buffer pointer.
--
-- The first argument is a pointer to the memory to write to. The second
-- argument is an IO action which is invoked if the store-core package
-- was built with the @force-alignment@ flag. The action should yield a
-- pointer to scratch memory as large as 'maybeAlignmentBufferSize'.
--
-- Since 0.4.2
unsafeMakePokeState :: Ptr Word8 -- ^ pokeStatePtr
                    -> IO (Ptr Word8) -- ^ action to produce pokeStateAlignPtr
                    -> IO PokeState
#if ALIGNED_MEMORY
unsafeMakePokeState ptr f = PokeState ptr <$> f
#else
unsafeMakePokeState :: Ptr Word8 -> IO (Ptr Word8) -> IO PokeState
unsafeMakePokeState Ptr Word8
ptr IO (Ptr Word8)
_ = PokeState -> IO PokeState
forall (m :: * -> *) a. Monad m => a -> m a
return (PokeState -> IO PokeState) -> PokeState -> IO PokeState
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> PokeState
PokeState Ptr Word8
ptr
#endif

-- | Exception thrown while running 'poke'. Note that other types of
-- exceptions could also be thrown. Invocations of 'fail' in the 'Poke'
-- monad causes this exception to be thrown.
--
-- 'PokeException's are not expected to occur in ordinary circumstances,
-- and usually indicate a programming error.
data PokeException = PokeException
    { PokeException -> Offset
pokeExByteIndex :: Offset
    , PokeException -> Text
pokeExMessage :: T.Text
    }
    deriving (PokeException -> PokeException -> Bool
(PokeException -> PokeException -> Bool)
-> (PokeException -> PokeException -> Bool) -> Eq PokeException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PokeException -> PokeException -> Bool
$c/= :: PokeException -> PokeException -> Bool
== :: PokeException -> PokeException -> Bool
$c== :: PokeException -> PokeException -> Bool
Eq, Offset -> PokeException -> ShowS
[PokeException] -> ShowS
PokeException -> String
(Offset -> PokeException -> ShowS)
-> (PokeException -> String)
-> ([PokeException] -> ShowS)
-> Show PokeException
forall a.
(Offset -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PokeException] -> ShowS
$cshowList :: [PokeException] -> ShowS
show :: PokeException -> String
$cshow :: PokeException -> String
showsPrec :: Offset -> PokeException -> ShowS
$cshowsPrec :: Offset -> PokeException -> ShowS
Show, Typeable)

instance Exception PokeException where
#if MIN_VERSION_base(4,8,0)
    displayException :: PokeException -> String
displayException (PokeException Offset
offset Text
msg) =
        String
"Exception while poking, at byte index " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
offset String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Text -> String
T.unpack Text
msg
#endif

-- | Throws a 'PokeException'. These should be avoided when possible,
-- they usually indicate a programming error.
pokeException :: T.Text -> Poke a
pokeException :: Text -> Poke a
pokeException Text
msg = (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, a)) -> Poke a)
-> (PokeState -> Offset -> IO (Offset, a)) -> Poke a
forall a b. (a -> b) -> a -> b
$ \PokeState
_ Offset
off -> PokeException -> IO (Offset, a)
forall e a. Exception e => e -> IO a
throwIO (Offset -> Text -> PokeException
PokeException Offset
off Text
msg)

------------------------------------------------------------------------
-- Peek monad

-- | 'Peek' actions are useful for building sequential deserializers.
--
-- They are actions which read from memory and construct values from it.
-- The 'Applicative' and 'Monad' instances make it easy to chain these
-- together to get more complicated deserializers. This machinery keeps
-- track of the current 'Ptr' and end-of-buffer 'Ptr'.
newtype Peek a = Peek
    { Peek a -> PeekState -> Ptr Word8 -> IO (PeekResult a)
runPeek :: PeekState -> Ptr Word8 -> IO (PeekResult a)
      -- ^ Run the 'Peek' action, with a 'Ptr' to the end of the buffer
      -- where data is poked, and a 'Ptr' to the current position. The
      -- result is the 'Ptr', along with a return value.
      --
      -- May throw a 'PeekException' if the memory contains invalid
      -- values.
    } deriving (a -> Peek b -> Peek a
(a -> b) -> Peek a -> Peek b
(forall a b. (a -> b) -> Peek a -> Peek b)
-> (forall a b. a -> Peek b -> Peek a) -> Functor Peek
forall a b. a -> Peek b -> Peek a
forall a b. (a -> b) -> Peek a -> Peek b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Peek b -> Peek a
$c<$ :: forall a b. a -> Peek b -> Peek a
fmap :: (a -> b) -> Peek a -> Peek b
$cfmap :: forall a b. (a -> b) -> Peek a -> Peek b
Functor)

-- | A result of a 'Peek' action containing the current 'Ptr' and a return value.
data PeekResult a = PeekResult {-# UNPACK #-} !(Ptr Word8) !a
    deriving (a -> PeekResult b -> PeekResult a
(a -> b) -> PeekResult a -> PeekResult b
(forall a b. (a -> b) -> PeekResult a -> PeekResult b)
-> (forall a b. a -> PeekResult b -> PeekResult a)
-> Functor PeekResult
forall a b. a -> PeekResult b -> PeekResult a
forall a b. (a -> b) -> PeekResult a -> PeekResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PeekResult b -> PeekResult a
$c<$ :: forall a b. a -> PeekResult b -> PeekResult a
fmap :: (a -> b) -> PeekResult a -> PeekResult b
$cfmap :: forall a b. (a -> b) -> PeekResult a -> PeekResult b
Functor)

instance Applicative Peek where
    pure :: a -> Peek a
pure a
x = (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek (\PeekState
_ Ptr Word8
ptr -> PeekResult a -> IO (PeekResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult a -> IO (PeekResult a))
-> PeekResult a -> IO (PeekResult a)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> a -> PeekResult a
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr a
x)
    {-# INLINE pure #-}
    Peek PeekState -> Ptr Word8 -> IO (PeekResult (a -> b))
f <*> :: Peek (a -> b) -> Peek a -> Peek b
<*> Peek PeekState -> Ptr Word8 -> IO (PeekResult a)
g = (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b)
-> (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a b. (a -> b) -> a -> b
$ \PeekState
end Ptr Word8
ptr1 -> do
        PeekResult Ptr Word8
ptr2 a -> b
f' <- PeekState -> Ptr Word8 -> IO (PeekResult (a -> b))
f PeekState
end Ptr Word8
ptr1
        PeekResult Ptr Word8
ptr3 a
g' <- PeekState -> Ptr Word8 -> IO (PeekResult a)
g PeekState
end Ptr Word8
ptr2
        PeekResult b -> IO (PeekResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult b -> IO (PeekResult b))
-> PeekResult b -> IO (PeekResult b)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> b -> PeekResult b
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr3 (a -> b
f' a
g')
    {-# INLINE (<*>) #-}
    Peek PeekState -> Ptr Word8 -> IO (PeekResult a)
f *> :: Peek a -> Peek b -> Peek b
*> Peek PeekState -> Ptr Word8 -> IO (PeekResult b)
g = (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b)
-> (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a b. (a -> b) -> a -> b
$ \PeekState
end Ptr Word8
ptr1 -> do
        PeekResult Ptr Word8
ptr2 a
_ <- PeekState -> Ptr Word8 -> IO (PeekResult a)
f PeekState
end Ptr Word8
ptr1
        PeekState -> Ptr Word8 -> IO (PeekResult b)
g PeekState
end Ptr Word8
ptr2
    {-# INLINE (*>) #-}

instance Monad Peek where
    return :: a -> Peek a
return = a -> Peek a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}
    >> :: Peek a -> Peek b -> Peek b
(>>) = Peek a -> Peek b -> Peek b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}
    Peek PeekState -> Ptr Word8 -> IO (PeekResult a)
x >>= :: Peek a -> (a -> Peek b) -> Peek b
>>= a -> Peek b
f = (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b)
-> (PeekState -> Ptr Word8 -> IO (PeekResult b)) -> Peek b
forall a b. (a -> b) -> a -> b
$ \PeekState
end Ptr Word8
ptr1 -> do
        PeekResult Ptr Word8
ptr2 a
x' <- PeekState -> Ptr Word8 -> IO (PeekResult a)
x PeekState
end Ptr Word8
ptr1
        Peek b -> PeekState -> Ptr Word8 -> IO (PeekResult b)
forall a. Peek a -> PeekState -> Ptr Word8 -> IO (PeekResult a)
runPeek (a -> Peek b
f a
x') PeekState
end Ptr Word8
ptr2
    {-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
    fail = peekException . T.pack
    {-# INLINE fail #-}
#endif

#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail Peek where
    fail :: String -> Peek a
fail = Text -> Peek a
forall a. Text -> Peek a
peekException (Text -> Peek a) -> (String -> Text) -> String -> Peek a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    {-# INLINE fail #-}
#endif

instance PrimMonad Peek where
    type PrimState Peek = RealWorld
    primitive :: (State# (PrimState Peek) -> (# State# (PrimState Peek), a #))
-> Peek a
primitive State# (PrimState Peek) -> (# State# (PrimState Peek), a #)
action = (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a)
-> (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a b. (a -> b) -> a -> b
$ \PeekState
_ Ptr Word8
ptr -> do
        a
x <- (State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive ((State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
unsafeCoerce# State# RealWorld -> (# State# RealWorld, a #)
State# (PrimState Peek) -> (# State# (PrimState Peek), a #)
action)
        PeekResult a -> IO (PeekResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult a -> IO (PeekResult a))
-> PeekResult a -> IO (PeekResult a)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> a -> PeekResult a
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr a
x
    {-# INLINE primitive #-}

instance MonadIO Peek where
    liftIO :: IO a -> Peek a
liftIO IO a
f = (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a)
-> (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a b. (a -> b) -> a -> b
$ \PeekState
_ Ptr Word8
ptr -> Ptr Word8 -> a -> PeekResult a
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr (a -> PeekResult a) -> IO a -> IO (PeekResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
f
    {-# INLINE liftIO #-}

-- | Holds a 'peekStatePtr', which is passed in to each 'Peek' action.
-- If the package is built with the 'force-alignment' flag, this also
-- has a hidden 'Ptr' field, which is used as scratch space during
-- unaligned reads.
#if ALIGNED_MEMORY
data PeekState = PeekState
    { peekStateEndPtr :: {-# UNPACK #-} !(Ptr Word8)
    , peekStateAlignPtr :: {-# UNPACK #-} !(Ptr Word8)
    }
#else
newtype PeekState = PeekState
    { PeekState -> Ptr Word8
peekStateEndPtr :: Ptr Word8 }
#endif

-- | Make a 'PeekState' from a buffer pointer.
--
-- The first argument is a pointer to the memory to write to. The second
-- argument is an IO action which is invoked if the store-core package
-- was built with the @force-alignment@ flag. The action should yield a
-- pointer to scratch memory as large as 'maybeAlignmentBufferSize'.
--
-- Since 0.4.2
unsafeMakePeekState :: Ptr Word8 -- ^ peekStateEndPtr
                    -> IO (Ptr Word8) -- ^ action to produce peekStateAlignPtr
                    -> IO PeekState
#if ALIGNED_MEMORY
unsafeMakePeekState ptr f = PeekState ptr <$> f
#else
unsafeMakePeekState :: Ptr Word8 -> IO (Ptr Word8) -> IO PeekState
unsafeMakePeekState Ptr Word8
ptr IO (Ptr Word8)
_ = PeekState -> IO PeekState
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekState -> IO PeekState) -> PeekState -> IO PeekState
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> PeekState
PeekState Ptr Word8
ptr
#endif

-- | Exception thrown while running 'peek'. Note that other types of
-- exceptions can also be thrown. Invocations of 'fail' in the 'Poke'
-- monad causes this exception to be thrown.
--
-- 'PeekException' is thrown when the data being decoded is invalid.
data PeekException = PeekException
    { PeekException -> Offset
peekExBytesFromEnd :: Offset
    , PeekException -> Text
peekExMessage :: T.Text
    } deriving (PeekException -> PeekException -> Bool
(PeekException -> PeekException -> Bool)
-> (PeekException -> PeekException -> Bool) -> Eq PeekException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeekException -> PeekException -> Bool
$c/= :: PeekException -> PeekException -> Bool
== :: PeekException -> PeekException -> Bool
$c== :: PeekException -> PeekException -> Bool
Eq, Offset -> PeekException -> ShowS
[PeekException] -> ShowS
PeekException -> String
(Offset -> PeekException -> ShowS)
-> (PeekException -> String)
-> ([PeekException] -> ShowS)
-> Show PeekException
forall a.
(Offset -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PeekException] -> ShowS
$cshowList :: [PeekException] -> ShowS
show :: PeekException -> String
$cshow :: PeekException -> String
showsPrec :: Offset -> PeekException -> ShowS
$cshowsPrec :: Offset -> PeekException -> ShowS
Show, Typeable)

instance Exception PeekException where
#if MIN_VERSION_base(4,8,0)
    displayException :: PeekException -> String
displayException (PeekException Offset
offset Text
msg) =
        String
"Exception while peeking, " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
offset String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
" bytes from end: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Text -> String
T.unpack Text
msg
#endif

-- | Throws a 'PeekException'.
peekException :: T.Text -> Peek a
peekException :: Text -> Peek a
peekException Text
msg = (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a)
-> (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
ptr -> PeekException -> IO (PeekResult a)
forall e a. Exception e => e -> IO a
throwIO (Offset -> Text -> PeekException
PeekException (PeekState -> Ptr Word8
peekStateEndPtr PeekState
ps Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
ptr) Text
msg)

-- | Throws a 'PeekException' about an attempt to read too many bytes.
tooManyBytes :: Int -> Int -> String -> IO void
tooManyBytes :: Offset -> Offset -> String -> IO void
tooManyBytes Offset
needed Offset
remaining String
ty =
    PeekException -> IO void
forall e a. Exception e => e -> IO a
throwIO (PeekException -> IO void) -> PeekException -> IO void
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PeekException
PeekException Offset
remaining (Text -> PeekException) -> Text -> PeekException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String
"Attempted to read too many bytes for " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
". Needed " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
needed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but only " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
remaining String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" remain."

-- | Throws a 'PeekException' about an attempt to read a negative number of bytes.
--
-- This can happen when we read invalid data -- the length tag is
-- basically random in this case.
negativeBytes :: Int -> Int -> String -> IO void
negativeBytes :: Offset -> Offset -> String -> IO void
negativeBytes Offset
needed Offset
remaining String
ty =
    PeekException -> IO void
forall e a. Exception e => e -> IO a
throwIO (PeekException -> IO void) -> PeekException -> IO void
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PeekException
PeekException Offset
remaining (Text -> PeekException) -> Text -> PeekException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String
"Attempted to read negative number of bytes for " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
". Tried to read " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
needed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".  This probably means that we're trying to read invalid data."

------------------------------------------------------------------------
-- Decoding and encoding ByteStrings


-- | Given a 'Poke' and its length, uses it to fill a 'ByteString'
--
-- This function is unsafe because the provided length must exactly
-- match the number of bytes used by the 'Poke'. It will throw
-- 'PokeException' errors when the buffer is under or overshot. However,
-- in the case of overshooting the buffer, memory corruption and
-- segfaults may occur.
unsafeEncodeWith :: Poke () -> Int -> ByteString
unsafeEncodeWith :: Poke () -> Offset -> ByteString
unsafeEncodeWith Poke ()
f Offset
l =
    Offset -> (Ptr Word8 -> IO ()) -> ByteString
BS.unsafeCreate Offset
l ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
#if ALIGNED_MEMORY
    allocaBytesAligned alignBufferSize 8 $ \aptr -> do
#endif
        let ps :: PokeState
ps = PokeState :: Ptr Word8 -> PokeState
PokeState
                { pokeStatePtr :: Ptr Word8
pokeStatePtr = Ptr Word8
ptr
#if ALIGNED_MEMORY
                , pokeStateAlignPtr = aptr
#endif
                }
        (Offset
o, ()) <- Poke () -> PokeState -> Offset -> IO (Offset, ())
forall a. Poke a -> PokeState -> Offset -> IO (Offset, a)
runPoke Poke ()
f PokeState
ps Offset
0
        Offset -> Offset -> IO ()
checkOffset Offset
o Offset
l

#if ALIGNED_MEMORY
alignBufferSize :: Int
alignBufferSize = 32
#endif

-- | If store-core is built with the @force-alignment@ flag, then this
-- will be a 'Just' value indicating the amount of memory that is
-- expected in the alignment buffer used by 'PeekState' and 'PokeState'.
-- Currently this will either be @Just 32@ or @Nothing@.
maybeAlignmentBufferSize :: Maybe Int
maybeAlignmentBufferSize :: Maybe Offset
maybeAlignmentBufferSize =
#if ALIGNED_MEMORY
  Just alignBufferSize
#else
  Maybe Offset
forall k1. Maybe k1
Nothing
#endif

-- | Checks if the offset matches the expected length, and throw a
-- 'PokeException' otherwise.
checkOffset :: Int -> Int -> IO ()
checkOffset :: Offset -> Offset -> IO ()
checkOffset Offset
o Offset
l
    | Offset
o Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
l = PokeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PokeException -> IO ()) -> PokeException -> IO ()
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PokeException
PokeException Offset
o (Text -> PokeException) -> Text -> PokeException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String
"encode overshot end of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        Offset -> String
forall a. Show a => a -> String
show Offset
l String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
" byte long buffer"
    | Offset
o Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
< Offset
l = PokeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PokeException -> IO ()) -> PokeException -> IO ()
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PokeException
PokeException Offset
o (Text -> PokeException) -> Text -> PokeException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String
"encode undershot end of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        Offset -> String
forall a. Show a => a -> String
show Offset
l String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
" byte long buffer"
    | Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Decodes a value from a 'ByteString', potentially throwing
-- exceptions, and taking a 'Peek' to run. It is an exception to not
-- consume all input.
decodeWith :: Peek a -> ByteString -> Either PeekException a
decodeWith :: Peek a -> ByteString -> Either PeekException a
decodeWith Peek a
mypeek = IO (Either PeekException a) -> Either PeekException a
forall a. IO a -> a
unsafePerformIO (IO (Either PeekException a) -> Either PeekException a)
-> (ByteString -> IO (Either PeekException a))
-> ByteString
-> Either PeekException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either PeekException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either PeekException a))
-> (ByteString -> IO a)
-> ByteString
-> IO (Either PeekException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peek a -> ByteString -> IO a
forall a. Peek a -> ByteString -> IO a
decodeIOWith Peek a
mypeek

-- | Decodes a value from a 'ByteString', potentially throwing
-- exceptions, and taking a 'Peek' to run. It is an exception to not
-- consume all input.
decodeExWith :: Peek a -> ByteString -> a
decodeExWith :: Peek a -> ByteString -> a
decodeExWith Peek a
f = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (ByteString -> IO a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peek a -> ByteString -> IO a
forall a. Peek a -> ByteString -> IO a
decodeIOWith Peek a
f

-- | Similar to 'decodeExWith', but it allows there to be more of the
-- buffer remaining. The 'Offset' of the buffer contents immediately
-- after the decoded value is returned.
decodeExPortionWith :: Peek a -> ByteString -> (Offset, a)
decodeExPortionWith :: Peek a -> ByteString -> (Offset, a)
decodeExPortionWith Peek a
f = IO (Offset, a) -> (Offset, a)
forall a. IO a -> a
unsafePerformIO (IO (Offset, a) -> (Offset, a))
-> (ByteString -> IO (Offset, a)) -> ByteString -> (Offset, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peek a -> ByteString -> IO (Offset, a)
forall a. Peek a -> ByteString -> IO (Offset, a)
decodeIOPortionWith Peek a
f

-- | Decodes a value from a 'ByteString', potentially throwing
-- exceptions, and taking a 'Peek' to run. It is an exception to not
-- consume all input.
decodeIOWith :: Peek a -> ByteString -> IO a
decodeIOWith :: Peek a -> ByteString -> IO a
decodeIOWith Peek a
mypeek (BS.PS ForeignPtr Word8
x Offset
s Offset
len) =
    ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
x ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr0 ->
        let ptr :: Ptr Word8
ptr = Ptr Word8
ptr0 Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
s
        in Peek a -> Ptr Word8 -> Offset -> IO a
forall a. Peek a -> Ptr Word8 -> Offset -> IO a
decodeIOWithFromPtr Peek a
mypeek Ptr Word8
ptr Offset
len

-- | Similar to 'decodeExPortionWith', but runs in the 'IO' monad.
decodeIOPortionWith :: Peek a -> ByteString -> IO (Offset, a)
decodeIOPortionWith :: Peek a -> ByteString -> IO (Offset, a)
decodeIOPortionWith Peek a
mypeek (BS.PS ForeignPtr Word8
x Offset
s Offset
len) =
    ForeignPtr Word8 -> (Ptr Word8 -> IO (Offset, a)) -> IO (Offset, a)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
x ((Ptr Word8 -> IO (Offset, a)) -> IO (Offset, a))
-> (Ptr Word8 -> IO (Offset, a)) -> IO (Offset, a)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr0 ->
        let ptr :: Ptr Word8
ptr = Ptr Word8
ptr0 Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
s
        in Peek a -> Ptr Word8 -> Offset -> IO (Offset, a)
forall a. Peek a -> Ptr Word8 -> Offset -> IO (Offset, a)
decodeIOPortionWithFromPtr Peek a
mypeek Ptr Word8
ptr Offset
len

-- | Like 'decodeIOWith', but using 'Ptr' and length instead of a
-- 'ByteString'.
decodeIOWithFromPtr :: Peek a -> Ptr Word8 -> Int -> IO a
decodeIOWithFromPtr :: Peek a -> Ptr Word8 -> Offset -> IO a
decodeIOWithFromPtr Peek a
mypeek Ptr Word8
ptr Offset
len = do
    (Offset
offset, a
x) <- Peek a -> Ptr Word8 -> Offset -> IO (Offset, a)
forall a. Peek a -> Ptr Word8 -> Offset -> IO (Offset, a)
decodeIOPortionWithFromPtr Peek a
mypeek Ptr Word8
ptr Offset
len
    if Offset
len Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
/= Offset
offset
       then PeekException -> IO a
forall e a. Exception e => e -> IO a
throwIO (PeekException -> IO a) -> PeekException -> IO a
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PeekException
PeekException (Offset
len Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
offset) Text
"Didn't consume all input."
       else a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Like 'decodeIOPortionWith', but using 'Ptr' and length instead of a 'ByteString'.
decodeIOPortionWithFromPtr :: Peek a -> Ptr Word8 -> Int -> IO (Offset, a)
decodeIOPortionWithFromPtr :: Peek a -> Ptr Word8 -> Offset -> IO (Offset, a)
decodeIOPortionWithFromPtr Peek a
mypeek Ptr Word8
ptr Offset
len =
    let end :: Ptr Word8
end = Ptr Word8
ptr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
len
        remaining :: Offset
remaining = Ptr Word8
end Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
ptr
    in do PeekResult Ptr Word8
ptr2 a
x' <-
#if ALIGNED_MEMORY
              allocaBytesAligned alignBufferSize 8 $ \aptr -> do
                  runPeek mypeek (PeekState end aptr) ptr
#else
              Peek a -> PeekState -> Ptr Word8 -> IO (PeekResult a)
forall a. Peek a -> PeekState -> Ptr Word8 -> IO (PeekResult a)
runPeek Peek a
mypeek (Ptr Word8 -> PeekState
PeekState Ptr Word8
end) Ptr Word8
ptr
#endif
        -- TODO: consider moving this condition to before running the peek?
          if Offset
len Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
remaining -- Do not perform the check on the new pointer, since it could have overflowed
              then PeekException -> IO (Offset, a)
forall e a. Exception e => e -> IO a
throwIO (PeekException -> IO (Offset, a))
-> PeekException -> IO (Offset, a)
forall a b. (a -> b) -> a -> b
$ Offset -> Text -> PeekException
PeekException (Ptr Word8
end Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
ptr2) Text
"Overshot end of buffer"
              else (Offset, a) -> IO (Offset, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8
ptr2 Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
ptr, a
x')

------------------------------------------------------------------------
-- Utilities for defining 'Store' instances based on 'Storable'

-- | A 'poke' implementation based on an instance of 'Storable'.
pokeStorable :: Storable a => a -> Poke ()
pokeStorable :: a -> Poke ()
pokeStorable a
x = (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, ())) -> Poke ())
-> (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a b. (a -> b) -> a -> b
$ \PokeState
ps Offset
offset -> do
    let targetPtr :: Ptr a
targetPtr = PokeState -> Ptr Word8
pokeStatePtr PokeState
ps Ptr Word8 -> Offset -> Ptr a
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
offset
#if ALIGNED_MEMORY
    -- If necessary, poke into the scratch buffer, and copy the results
    -- to the output buffer.
    let bufStart = pokeStateAlignPtr ps
        alignStart = alignPtr (pokeStateAlignPtr ps) (alignment x)
        sz = sizeOf x
    if targetPtr == alignPtr targetPtr (alignment x)
        -- If we luck out and the output is already aligned, just poke it
        -- directly.
        then poke targetPtr x
        else (if (alignStart `plusPtr` sz) < (bufStart `plusPtr` alignBufferSize)
            then do
                poke (castPtr alignStart) x
                BS.memcpy (castPtr targetPtr) alignStart sz
            else do
                allocaBytesAligned sz (alignment x) $ \tempPtr -> do
                    poke tempPtr x
                    BS.memcpy (castPtr targetPtr) (castPtr tempPtr) sz)
#else
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
targetPtr a
x
#endif
    let !newOffset :: Offset
newOffset = Offset
offset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ a -> Offset
forall a. Storable a => a -> Offset
sizeOf a
x
    (Offset, ()) -> IO (Offset, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset
newOffset, ())
{-# INLINE pokeStorable #-}

-- FIXME: make it the responsibility of the caller to check this.

-- | A 'peek' implementation based on an instance of 'Storable' and
-- 'Typeable'.
peekStorable :: forall a. (Storable a, Typeable a) => Peek a
peekStorable :: Peek a
peekStorable = String -> Peek a
forall a. Storable a => String -> Peek a
peekStorableTy (TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
{-# INLINE peekStorable #-}

-- | A 'peek' implementation based on an instance of 'Storable'. Use
-- this if the type is not 'Typeable'.
peekStorableTy :: forall a. Storable a => String -> Peek a
peekStorableTy :: String -> Peek a
peekStorableTy String
ty = (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a)
-> (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
ptr -> do
    let ptr' :: Ptr Word8
ptr' = Ptr Word8
ptr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
sz
        sz :: Offset
sz = a -> Offset
forall a. Storable a => a -> Offset
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
        remaining :: Offset
remaining = PeekState -> Ptr Word8
peekStateEndPtr PeekState
ps Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
ptr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Offset
sz Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
remaining) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- Do not perform the check on the new pointer, since it could have overflowed
        Offset -> Offset -> String -> IO ()
forall void. Offset -> Offset -> String -> IO void
tooManyBytes Offset
sz Offset
remaining String
ty
#if ALIGNED_MEMORY
    let bufStart = peekStateAlignPtr ps
        alignStart = alignPtr (peekStateAlignPtr ps) alignAmount
        alignAmount = alignment (undefined :: a)
    x <- if ptr == alignPtr ptr alignAmount
        then Storable.peek (castPtr ptr)
        else (if (alignStart `plusPtr` sz) < (bufStart `plusPtr` alignBufferSize)
            then do
                BS.memcpy (castPtr alignStart) ptr sz
                Storable.peek (castPtr alignStart)
            else do
                allocaBytesAligned sz alignAmount $ \tempPtr -> do
                    BS.memcpy tempPtr (castPtr ptr) sz
                    Storable.peek (castPtr tempPtr))
#else
    a
x <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
Storable.peek (Ptr Word8 -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr)
#endif
    PeekResult a -> IO (PeekResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult a -> IO (PeekResult a))
-> PeekResult a -> IO (PeekResult a)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> a -> PeekResult a
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr' a
x
{-# INLINE peekStorableTy #-}

------------------------------------------------------------------------
-- Utilities for implementing 'Store' instances via memcpy

-- | Copy a section of memory, based on a 'ForeignPtr', to the output.
-- Note that this operation is unsafe, the offset and length parameters
-- are not checked.
pokeFromForeignPtr :: ForeignPtr a -> Int -> Int -> Poke ()
pokeFromForeignPtr :: ForeignPtr a -> Offset -> Offset -> Poke ()
pokeFromForeignPtr ForeignPtr a
sourceFp Offset
sourceOffset Offset
len =
    (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, ())) -> Poke ())
-> (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a b. (a -> b) -> a -> b
$ \PokeState
targetState Offset
targetOffset -> do
        let targetPtr :: Ptr Word8
targetPtr = PokeState -> Ptr Word8
pokeStatePtr PokeState
targetState
        ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
sourceFp ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
sourcePtr ->
            Ptr Word8 -> Ptr Word8 -> Offset -> IO ()
BS.memcpy (Ptr Word8
targetPtr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
targetOffset)
                      (Ptr a
sourcePtr Ptr a -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
sourceOffset)
                      Offset
len
        let !newOffset :: Offset
newOffset = Offset
targetOffset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
len
        (Offset, ()) -> IO (Offset, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset
newOffset, ())

-- | Allocate a plain ForeignPtr (no finalizers), of the specified
-- length and fill it with bytes from the input.
peekToPlainForeignPtr :: String -> Int -> Peek (ForeignPtr a)
peekToPlainForeignPtr :: String -> Offset -> Peek (ForeignPtr a)
peekToPlainForeignPtr String
ty Offset
len =
    (PeekState -> Ptr Word8 -> IO (PeekResult (ForeignPtr a)))
-> Peek (ForeignPtr a)
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult (ForeignPtr a)))
 -> Peek (ForeignPtr a))
-> (PeekState -> Ptr Word8 -> IO (PeekResult (ForeignPtr a)))
-> Peek (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
sourcePtr -> do
        let ptr2 :: Ptr Word8
ptr2 = Ptr Word8
sourcePtr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
len
            remaining :: Offset
remaining = PeekState -> Ptr Word8
peekStateEndPtr PeekState
ps Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
sourcePtr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Offset
len Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
remaining) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- Do not perform the check on the new pointer, since it could have overflowed
            Offset -> Offset -> String -> IO ()
forall void. Offset -> Offset -> String -> IO void
tooManyBytes Offset
len Offset
remaining String
ty
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Offset
len Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
< Offset
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Offset -> Offset -> String -> IO ()
forall void. Offset -> Offset -> String -> IO void
negativeBytes Offset
len Offset
remaining String
ty
        ForeignPtr Word8
fp <- Offset -> IO (ForeignPtr Word8)
forall a. Offset -> IO (ForeignPtr a)
BS.mallocByteString Offset
len
        ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
targetPtr ->
            Ptr Word8 -> Ptr Word8 -> Offset -> IO ()
BS.memcpy Ptr Word8
targetPtr (Ptr Word8 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
sourcePtr) Offset
len
        PeekResult (ForeignPtr a) -> IO (PeekResult (ForeignPtr a))
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult (ForeignPtr a) -> IO (PeekResult (ForeignPtr a)))
-> PeekResult (ForeignPtr a) -> IO (PeekResult (ForeignPtr a))
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> ForeignPtr a -> PeekResult (ForeignPtr a)
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr2 (ForeignPtr Word8 -> ForeignPtr a
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
fp)

-- | Copy a section of memory, based on a 'Ptr', to the output. Note
-- that this operation is unsafe, because the offset and length
-- parameters are not checked.
pokeFromPtr :: Ptr a -> Int -> Int -> Poke ()
pokeFromPtr :: Ptr a -> Offset -> Offset -> Poke ()
pokeFromPtr Ptr a
sourcePtr Offset
sourceOffset Offset
len =
    (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, ())) -> Poke ())
-> (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a b. (a -> b) -> a -> b
$ \PokeState
targetState Offset
targetOffset -> do
        let targetPtr :: Ptr Word8
targetPtr = PokeState -> Ptr Word8
pokeStatePtr PokeState
targetState
        Ptr Word8 -> Ptr Word8 -> Offset -> IO ()
BS.memcpy (Ptr Word8
targetPtr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
targetOffset)
                  (Ptr a
sourcePtr Ptr a -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
sourceOffset)
                  Offset
len
        let !newOffset :: Offset
newOffset = Offset
targetOffset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
len
        (Offset, ()) -> IO (Offset, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset
newOffset, ())

-- TODO: have a safer variant with the check?

-- | Copy a section of memory, based on a 'ByteArray#', to the output.
-- Note that this operation is unsafe, because the offset and length
-- parameters are not checked.
pokeFromByteArray :: ByteArray# -> Int -> Int -> Poke ()
pokeFromByteArray :: ByteArray# -> Offset -> Offset -> Poke ()
pokeFromByteArray ByteArray#
sourceArr Offset
sourceOffset Offset
len =
    (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a. (PokeState -> Offset -> IO (Offset, a)) -> Poke a
Poke ((PokeState -> Offset -> IO (Offset, ())) -> Poke ())
-> (PokeState -> Offset -> IO (Offset, ())) -> Poke ()
forall a b. (a -> b) -> a -> b
$ \PokeState
targetState Offset
targetOffset -> do
        let target :: Ptr Any
target = (PokeState -> Ptr Word8
pokeStatePtr PokeState
targetState) Ptr Word8 -> Offset -> Ptr Any
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
targetOffset
        ByteArray# -> Offset -> Ptr Any -> Offset -> IO ()
forall a. ByteArray# -> Offset -> Ptr a -> Offset -> IO ()
copyByteArrayToAddr ByteArray#
sourceArr Offset
sourceOffset Ptr Any
target Offset
len
        let !newOffset :: Offset
newOffset = Offset
targetOffset Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
len
        (Offset, ()) -> IO (Offset, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset
newOffset, ())

-- | Allocate a ByteArray of the specified length and fill it with bytes
-- from the input.
peekToByteArray :: String -> Int -> Peek ByteArray
peekToByteArray :: String -> Offset -> Peek ByteArray
peekToByteArray String
ty Offset
len =
    (PeekState -> Ptr Word8 -> IO (PeekResult ByteArray))
-> Peek ByteArray
forall a. (PeekState -> Ptr Word8 -> IO (PeekResult a)) -> Peek a
Peek ((PeekState -> Ptr Word8 -> IO (PeekResult ByteArray))
 -> Peek ByteArray)
-> (PeekState -> Ptr Word8 -> IO (PeekResult ByteArray))
-> Peek ByteArray
forall a b. (a -> b) -> a -> b
$ \PeekState
ps Ptr Word8
sourcePtr -> do
        let ptr2 :: Ptr Word8
ptr2 = Ptr Word8
sourcePtr Ptr Word8 -> Offset -> Ptr Word8
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` Offset
len
            remaining :: Offset
remaining = PeekState -> Ptr Word8
peekStateEndPtr PeekState
ps Ptr Word8 -> Ptr Word8 -> Offset
forall a b. Ptr a -> Ptr b -> Offset
`minusPtr` Ptr Word8
sourcePtr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Offset
len Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
remaining) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- Do not perform the check on the new pointer, since it could have overflowed
            Offset -> Offset -> String -> IO ()
forall void. Offset -> Offset -> String -> IO void
tooManyBytes Offset
len Offset
remaining String
ty
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Offset
len Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
< Offset
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Offset -> Offset -> String -> IO ()
forall void. Offset -> Offset -> String -> IO void
negativeBytes Offset
len Offset
remaining String
ty
        MutableByteArray RealWorld
marr <- Offset -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Offset -> m (MutableByteArray (PrimState m))
newByteArray Offset
len
        Ptr Word8
-> MutableByteArray (PrimState IO) -> Offset -> Offset -> IO ()
forall a.
Ptr a
-> MutableByteArray (PrimState IO) -> Offset -> Offset -> IO ()
copyAddrToByteArray Ptr Word8
sourcePtr MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr Offset
0 Offset
len
        ByteArray
x <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr
        PeekResult ByteArray -> IO (PeekResult ByteArray)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeekResult ByteArray -> IO (PeekResult ByteArray))
-> PeekResult ByteArray -> IO (PeekResult ByteArray)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> ByteArray -> PeekResult ByteArray
forall a. Ptr Word8 -> a -> PeekResult a
PeekResult Ptr Word8
ptr2 ByteArray
x

-- | Wrapper around @copyByteArrayToAddr#@ primop.
copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
copyByteArrayToAddr :: ByteArray# -> Offset -> Ptr a -> Offset -> IO ()
copyByteArrayToAddr ByteArray#
arr (I# Int#
offset) (Ptr Addr#
addr) (I# Int#
len) =
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# ByteArray#
-> Int# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld
forall d.
ByteArray# -> Int# -> Addr# -> Int# -> State# d -> State# d
copyByteArrayToAddr# ByteArray#
arr Int#
offset Addr#
addr Int#
len State# RealWorld
s, () #))
{-# INLINE copyByteArrayToAddr  #-}

-- | Wrapper around @copyAddrToByteArray#@ primop.
copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO ()
copyAddrToByteArray :: Ptr a
-> MutableByteArray (PrimState IO) -> Offset -> Offset -> IO ()
copyAddrToByteArray (Ptr Addr#
addr) (MutableByteArray MutableByteArray# (PrimState IO)
arr) (I# Int#
offset) (I# Int#
len) =
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr MutableByteArray# RealWorld
MutableByteArray# (PrimState IO)
arr Int#
offset Int#
len State# RealWorld
s, () #))
{-# INLINE copyAddrToByteArray  #-}