Initial commit

bundled/Data/ByteArray/Bytes.hs

@@ -0,0 +1,216 @@
+-- |
+-- Module      : Data.ByteArray.Bytes
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+-- Simple and efficient byte array types
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Data.ByteArray.Bytes
+    ( Bytes
+    ) where
+
+#if MIN_VERSION_base(4,15,0)
+import           GHC.Exts (unsafeCoerce#)
+#endif
+import           GHC.Word
+import           GHC.Char (chr)
+import           GHC.Types
+import           GHC.Prim
+import           GHC.Ptr
+#if MIN_VERSION_base(4,9,0)
+import           Data.Semigroup
+import           Data.Foldable (toList)
+#else
+import           Data.Monoid
+#endif
+import           Data.Memory.PtrMethods
+import           Data.Memory.Internal.Imports
+import           Data.Memory.Internal.CompatPrim
+import           Data.Memory.Internal.Compat      (unsafeDoIO)
+import           Data.ByteArray.Types
+import           Data.Typeable
+
+#ifdef MIN_VERSION_basement
+import           Basement.NormalForm
+#endif
+import           Basement.IntegralConv
+
+-- | Simplest Byte Array
+data Bytes = Bytes (MutableByteArray# RealWorld)
+  deriving (Typeable)
+
+instance Show Bytes where
+    showsPrec p b r = showsPrec p (bytesUnpackChars b []) r
+instance Eq Bytes where
+    (==) = bytesEq
+instance Ord Bytes where
+    compare = bytesCompare
+#if MIN_VERSION_base(4,9,0)
+instance Semigroup Bytes where
+    b1 <> b2      = unsafeDoIO $ bytesAppend b1 b2
+    sconcat       = unsafeDoIO . bytesConcat . toList
+#endif
+instance Monoid Bytes where
+    mempty        = unsafeDoIO (newBytes 0)
+#if !(MIN_VERSION_base(4,11,0))
+    mappend b1 b2 = unsafeDoIO $ bytesAppend b1 b2
+    mconcat       = unsafeDoIO . bytesConcat
+#endif
+instance NFData Bytes where
+    rnf b = b `seq` ()
+#ifdef MIN_VERSION_basement
+instance NormalForm Bytes where
+    toNormalForm b = b `seq` ()
+#endif
+instance ByteArrayAccess Bytes where
+    length        = bytesLength
+    withByteArray = withBytes
+instance ByteArray Bytes where
+    allocRet = bytesAllocRet
+
+------------------------------------------------------------------------
+newBytes :: Int -> IO Bytes
+newBytes (I# sz)
+    | booleanPrim (sz <# 0#) = error "Bytes: size must be >= 0"
+    | otherwise              = IO $ \s ->
+        case newAlignedPinnedByteArray# sz 8# s of
+            (# s', mbarr #) -> (# s', Bytes mbarr #)
+
+touchBytes :: Bytes -> IO ()
+touchBytes (Bytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #)
+{-# INLINE touchBytes #-}
+
+sizeofBytes :: Bytes -> Int
+sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba)
+{-# INLINE sizeofBytes #-}
+
+withPtr :: Bytes -> (Ptr p -> IO a) -> IO a
+withPtr b@(Bytes mba) f = do
+    a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba)))
+    touchBytes b
+    return a
+------------------------------------------------------------------------
+
+bytesAlloc :: Int -> (Ptr p -> IO ()) -> IO Bytes
+bytesAlloc sz f = do
+    ba <- newBytes sz
+    withPtr ba f
+    return ba
+
+bytesConcat :: [Bytes] -> IO Bytes
+bytesConcat l = bytesAlloc retLen (copy l)
+  where
+    !retLen = sum $ map bytesLength l
+
+    copy []     _   = return ()
+    copy (x:xs) dst = do
+        withPtr x $ \src -> memCopy dst src chunkLen
+        copy xs (dst `plusPtr` chunkLen)
+      where
+        !chunkLen = bytesLength x
+
+bytesAppend :: Bytes -> Bytes -> IO Bytes
+bytesAppend b1 b2 = bytesAlloc retLen $ \dst -> do
+    withPtr b1 $ \s1 -> memCopy dst                  s1 len1
+    withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2
+  where
+    !len1   = bytesLength b1
+    !len2   = bytesLength b2
+    !retLen = len1 + len2
+
+bytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, Bytes)
+bytesAllocRet sz f = do
+    ba <- newBytes sz
+    r <- withPtr ba f
+    return (r, ba)
+
+bytesLength :: Bytes -> Int
+bytesLength = sizeofBytes
+{-# LANGUAGE bytesLength #-}
+
+withBytes :: Bytes -> (Ptr p -> IO a) -> IO a
+withBytes = withPtr
+
+bytesEq :: Bytes -> Bytes -> Bool
+bytesEq b1@(Bytes m1) b2@(Bytes m2)
+    | l1 /= l2  = False
+    | otherwise = unsafeDoIO $ IO $ \s -> loop 0# s
+  where
+    !l1@(I# len) = bytesLength b1
+    !l2          = bytesLength b2
+
+    loop i s
+        | booleanPrim (i ==# len) = (# s, True #)
+        | otherwise               =
+            case readWord8Array# m1 i s of
+                (# s', e1 #) -> case readWord8Array# m2 i s' of
+                    (# s'', e2 #) ->
+                        if (W8# e1) == (W8# e2)
+                            then loop (i +# 1#) s''
+                            else (# s'', False #)
+    {-# INLINE loop #-}
+
+bytesCompare :: Bytes -> Bytes -> Ordering
+bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ loop 0
+  where
+    !l1  = bytesLength b1
+    !l2  = bytesLength b2
+    !len = min l1 l2
+
+    loop !i
+        | i == len =
+            if l1 == l2
+                then pure EQ
+                else if l1 > l2 then pure GT
+                                else pure LT
+        | otherwise               = do
+            e1 <- read8 m1 i
+            e2 <- read8 m2 i
+            if e1 == e2
+                then loop (i+1)
+                else if e1 < e2 then pure LT
+                                else pure GT
+
+    read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of
+                                    (# s2, e #) -> (# s2, W8# e #)
+
+bytesUnpackChars :: Bytes -> String -> String
+bytesUnpackChars (Bytes mba) xs = chunkLoop 0#
+  where
+    !len = sizeofMutableByteArray# mba
+    -- chunk 64 bytes at a time
+    chunkLoop :: Int# -> [Char]
+    chunkLoop idx
+        | booleanPrim (len ==# idx) = []
+        | booleanPrim ((len -# idx) ># 63#) =
+            bytesLoop idx 64# (chunkLoop (idx +# 64#))
+        | otherwise =
+            bytesLoop idx (len -# idx) xs
+
+    bytesLoop idx chunkLenM1 paramAcc = unsafeDoIO $
+        loop (idx +# chunkLenM1 -# 1#) paramAcc
+      where loop i acc
+                | booleanPrim (i ==# idx) = do
+                    c <- rChar i
+                    return (c : acc)
+                | otherwise = do
+                    c <- rChar i
+                    loop (i -# 1#) (c : acc)
+
+    rChar :: Int# -> IO Char
+    rChar idx = IO $ \s ->
+        case readWord8Array# mba idx s of
+            (# s2, w #) -> (# s2, chr (integralUpsize (W8# w)) #)
+
+{-
+bytesShowHex :: Bytes -> String
+bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b)
+{-# NOINLINE bytesShowHex #-}
+-}

bundled/Data/ByteArray/Encoding.hs

@@ -0,0 +1,162 @@
+-- |
+-- Module      : Data.ByteArray.Encoding
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Base conversions for 'ByteArray'.
+--
+module Data.ByteArray.Encoding
+    ( convertToBase
+    , convertFromBase
+    , Base(..)
+    ) where
+
+import           Data.ByteArray.Types
+import qualified Data.ByteArray.Types        as B
+import qualified Data.ByteArray.Methods      as B
+import           Data.Memory.Internal.Compat
+import           Data.Memory.Encoding.Base16
+import           Data.Memory.Encoding.Base32
+import           Data.Memory.Encoding.Base64
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Data.ByteString
+
+-- | The different bases that can be used.
+--
+-- See <http://tools.ietf.org/html/rfc4648 RFC4648> for details.
+-- In particular, Base64 can be standard or
+-- <http://tools.ietf.org/html/rfc4648#section-5 URL-safe>. URL-safe
+-- encoding is often used in other specifications without
+-- <http://tools.ietf.org/html/rfc4648#section-3.2 padding> characters.
+--
+-- <https://www.ietf.org/rfc/rfc2045.txt RFC 2045>
+-- defines a separate Base64 encoding, which is not supported. This format
+-- requires a newline at least every 76 encoded characters, which works around
+-- limitations of older email programs that could not handle long lines.
+-- Be aware that other languages, such as Ruby, encode the RFC 2045 version
+-- by default. To decode their output, remove all newlines before decoding.
+--
+-- ==== Examples
+--
+-- A quick example to show the differences:
+--
+-- >>> let input = "Is 3 > 2?" :: ByteString
+-- >>> let convertedTo base = convertToBase base input :: ByteString
+-- >>> convertedTo Base16
+-- "49732033203e20323f"
+-- >>> convertedTo Base32
+-- "JFZSAMZAHYQDEPY="
+-- >>> convertedTo Base64
+-- "SXMgMyA+IDI/"
+-- >>> convertedTo Base64URLUnpadded
+-- "SXMgMyA-IDI_"
+-- >>> convertedTo Base64OpenBSD
+-- "QVKeKw.8GBG9"
+--
+data Base = Base16            -- ^ similar to hexadecimal
+          | Base32
+          | Base64            -- ^ standard Base64
+          | Base64URLUnpadded -- ^ unpadded URL-safe Base64
+          | Base64OpenBSD     -- ^ Base64 as used in OpenBSD password encoding (such as bcrypt)
+          deriving (Show,Eq)
+
+-- | Encode some bytes to the equivalent representation in a specific 'Base'.
+--
+-- ==== Examples
+--
+-- Convert a 'ByteString' to base-64:
+--
+-- >>> convertToBase Base64 ("foobar" :: ByteString) :: ByteString
+-- "Zm9vYmFy"
+--
+convertToBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> bout
+convertToBase base b = case base of
+    Base16 -> doConvert (binLength * 2) toHexadecimal
+    Base32 -> let (q,r)  = binLength `divMod` 5
+                  outLen = 8 * (if r == 0 then q else q + 1)
+               in doConvert outLen toBase32
+    Base64 -> doConvert base64Length toBase64
+    -- Base64URL         -> doConvert base64Length (toBase64URL True)
+    Base64URLUnpadded -> doConvert base64UnpaddedLength (toBase64URL False)
+    Base64OpenBSD     -> doConvert base64UnpaddedLength toBase64OpenBSD
+  where
+    binLength = B.length b
+
+    base64Length = let (q,r) = binLength `divMod` 3
+                    in 4 * (if r == 0 then q else q+1)
+
+    base64UnpaddedLength = let (q,r) = binLength `divMod` 3
+                            in 4 * q + (if r == 0 then 0 else r+1)
+    doConvert l f =
+        B.unsafeCreate l $ \bout ->
+        B.withByteArray b     $ \bin  ->
+            f bout bin binLength
+
+-- | Try to decode some bytes from the equivalent representation in a specific 'Base'.
+--
+-- ==== Examples
+--
+-- Successfully convert from base-64 to a 'ByteString':
+--
+-- >>> convertFromBase Base64 ("Zm9vYmFy" :: ByteString) :: Either String ByteString
+-- Right "foobar"
+--
+-- Trying to decode invalid data will return an error string:
+--
+-- >>> convertFromBase Base64 ("!!!" :: ByteString) :: Either String ByteString
+-- Left "base64: input: invalid length"
+--
+convertFromBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> Either String bout
+convertFromBase Base16 b
+    | odd (B.length b) = Left "base16: input: invalid length"
+    | otherwise        = unsafeDoIO $ do
+        (ret, out) <-
+            B.allocRet (B.length b `div` 2) $ \bout ->
+            B.withByteArray b               $ \bin  ->
+                fromHexadecimal bout bin (B.length b)
+        case ret of
+            Nothing  -> return $ Right out
+            Just ofs -> return $ Left ("base16: input: invalid encoding at offset: " ++ show ofs)
+convertFromBase Base32 b = unsafeDoIO $
+    withByteArray b $ \bin -> do
+        mDstLen <- unBase32Length bin (B.length b)
+        case mDstLen of
+            Nothing     -> return $ Left "base32: input: invalid length"
+            Just dstLen -> do
+                (ret, out) <- B.allocRet dstLen $ \bout -> fromBase32 bout bin (B.length b)
+                case ret of
+                    Nothing  -> return $ Right out
+                    Just ofs -> return $ Left ("base32: input: invalid encoding at offset: " ++ show ofs)
+convertFromBase Base64 b = unsafeDoIO $
+    withByteArray b $ \bin -> do
+        mDstLen <- unBase64Length bin (B.length b)
+        case mDstLen of
+            Nothing     -> return $ Left "base64: input: invalid length"
+            Just dstLen -> do
+                (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64 bout bin (B.length b)
+                case ret of
+                    Nothing  -> return $ Right out
+                    Just ofs -> return $ Left ("base64: input: invalid encoding at offset: " ++ show ofs)
+convertFromBase Base64URLUnpadded b = unsafeDoIO $
+    withByteArray b $ \bin ->
+        case unBase64LengthUnpadded (B.length b) of
+            Nothing     -> return $ Left "base64URL unpadded: input: invalid length"
+            Just dstLen -> do
+                (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64URLUnpadded bout bin (B.length b)
+                case ret of
+                    Nothing  -> return $ Right out
+                    Just ofs -> return $ Left ("base64URL unpadded: input: invalid encoding at offset: " ++ show ofs)
+convertFromBase Base64OpenBSD b = unsafeDoIO $
+    withByteArray b $ \bin ->
+        case unBase64LengthUnpadded (B.length b) of
+            Nothing     -> return $ Left "base64 unpadded: input: invalid length"
+            Just dstLen -> do
+                (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64OpenBSD bout bin (B.length b)
+                case ret of
+                    Nothing  -> return $ Right out
+                    Just ofs -> return $ Left ("base64 unpadded: input: invalid encoding at offset: " ++ show ofs)
+

bundled/Data/ByteArray/Hash.hs

@@ -0,0 +1,78 @@
+-- |
+-- Module      : Data.ByteArray.Hash
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : good
+--
+-- provide the SipHash algorithm.
+-- reference: <http://131002.net/siphash/siphash.pdf>
+--
+{-# LANGUAGE BangPatterns #-}
+module Data.ByteArray.Hash
+    (
+    -- * SipHash
+      SipKey(..)
+    , SipHash(..)
+    , sipHash
+    , sipHashWith
+    -- * FNV1 and FNV1a (32 and 64 bits)
+    , FnvHash32(..)
+    , FnvHash64(..)
+    , fnv1Hash
+    , fnv1aHash
+    , fnv1_64Hash
+    , fnv1a_64Hash
+    ) where
+
+import           Data.Memory.Internal.Compat
+import           Data.Memory.Hash.SipHash
+import           Data.Memory.Hash.FNV
+import qualified Data.ByteArray.Types   as B
+
+-- | Compute the SipHash tag of a byte array for a given key.
+--
+-- 'sipHash` is equivalent to 'sipHashWith 2 4'
+sipHash :: B.ByteArrayAccess ba
+        => SipKey
+        -> ba
+        -> SipHash
+sipHash key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hash key p (B.length ba)
+
+-- | Compute the SipHash tag of a byte array for a given key.
+--
+-- The user can choose the C and D numbers of rounds.
+--
+-- calling 'sipHash` is equivalent to 'sipHashWith 2 4'
+sipHashWith :: B.ByteArrayAccess ba
+            => Int    -- ^ c rounds
+            -> Int    -- ^ d rounds
+            -> SipKey -- ^ key
+            -> ba     -- ^ data to hash
+            -> SipHash
+sipHashWith c d key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hashWith c d key p (B.length ba)
+
+
+-- | Compute the FNV1 32 bit hash value of a byte array
+fnv1Hash :: B.ByteArrayAccess ba
+         => ba
+         -> FnvHash32
+fnv1Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1 p (B.length ba)
+
+-- | Compute the FNV1a 32 bit hash value of a byte array
+fnv1aHash :: B.ByteArrayAccess ba
+          => ba
+          -> FnvHash32
+fnv1aHash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a p (B.length ba)
+
+-- | Compute the FNV1 64 bit hash value of a byte array
+fnv1_64Hash :: B.ByteArrayAccess ba
+            => ba
+            -> FnvHash64
+fnv1_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1_64 p (B.length ba)
+
+-- | Compute the FNV1a 64 bit hash value of a byte array
+fnv1a_64Hash :: B.ByteArrayAccess ba
+             => ba
+             -> FnvHash64
+fnv1a_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a_64 p (B.length ba)

bundled/Data/ByteArray/Mapping.hs

@@ -0,0 +1,84 @@
+-- |
+-- Module      : Data.ByteArray.Mapping
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+module Data.ByteArray.Mapping
+    ( toW64BE
+    , toW64LE
+    , fromW64BE
+    , mapAsWord64
+    , mapAsWord128
+    ) where
+
+import           Data.ByteArray.Types
+import           Data.ByteArray.Methods
+import           Data.Memory.Internal.Compat
+import           Data.Memory.Internal.Imports hiding (empty)
+import           Data.Memory.Endian
+import           Data.Memory.ExtendedWords
+import           Foreign.Storable
+import           Foreign.Ptr
+
+import           Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred)
+
+-- | Transform a bytearray at a specific offset into
+-- a Word64 tagged as BE (Big Endian)
+--
+-- no bounds checking. unsafe
+toW64BE :: ByteArrayAccess bs => bs -> Int -> BE Word64
+toW64BE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)
+
+-- | Transform a bytearray at a specific offset into
+-- a Word64 tagged as LE (Little Endian)
+--
+-- no bounds checking. unsafe
+toW64LE :: ByteArrayAccess bs => bs -> Int -> LE Word64
+toW64LE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)
+
+-- | Serialize a @Word64@ to a @ByteArray@ in big endian format
+fromW64BE :: (ByteArray ba) => Word64 -> ba
+fromW64BE n = allocAndFreeze 8 $ \p -> poke p (toBE n)
+
+-- | map blocks of 128 bits of a bytearray, creating a new bytestring
+-- of equivalent size where each blocks has been mapped through @f@
+--
+-- no length checking is done. unsafe
+mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs
+mapAsWord128 f bs =
+    unsafeCreate len $ \dst ->
+    withByteArray bs $ \src ->
+        loop (len `div` 16) dst src
+  where
+        len        = length bs
+        loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO ()
+        loop 0 _ _ = return ()
+        loop i d s = do
+            w1 <- peek s
+            w2 <- peek (s `plusPtr` 8)
+            let (Word128 r1 r2) = f (Word128 (fromBE w1) (fromBE w2))
+            poke d               (toBE r1)
+            poke (d `plusPtr` 8) (toBE r2)
+            loop (i-1) (d `plusPtr` 16) (s `plusPtr` 16)
+
+-- | map blocks of 64 bits of a bytearray, creating a new bytestring
+-- of equivalent size where each blocks has been mapped through @f@
+--
+-- no length checking is done. unsafe
+mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs
+mapAsWord64 f bs =
+    unsafeCreate len $ \dst ->
+    withByteArray bs $ \src ->
+        loop (len `div` 8) dst src
+  where
+        len        = length bs
+
+        loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO ()
+        loop 0 _ _ = return ()
+        loop i d s = do
+            w <- peek s
+            let r = f (fromBE w)
+            poke d (toBE r)
+            loop (i-1) (d `plusPtr` 8) (s `plusPtr` 8)

bundled/Data/ByteArray/MemView.hs

@@ -0,0 +1,38 @@
+-- |
+-- Module      : Data.ByteArray.MemView
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+module Data.ByteArray.MemView
+    ( MemView(..)
+    , memViewPlus
+    ) where
+
+import           Foreign.Ptr
+import           Data.ByteArray.Types
+import           Data.Memory.Internal.Imports
+
+-- | A simple abstraction to a piece of memory.
+--
+-- Do beware that garbage collection related to
+-- piece of memory could be triggered before this
+-- is used.
+--
+-- Only use with the appropriate handler has been
+-- used (e.g. withForeignPtr on ForeignPtr)
+--
+data MemView = MemView {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !Int
+    deriving (Show,Eq)
+
+instance ByteArrayAccess MemView where
+    length (MemView _ l) = l
+    withByteArray (MemView p _) f = f (castPtr p)
+
+-- | Increase the memory view while reducing the size of the window
+--
+-- this is useful as an abstraction to represent the current offset
+-- in a buffer, and the remaining bytes left.
+memViewPlus :: MemView -> Int -> MemView
+memViewPlus (MemView p len) n = MemView (p `plusPtr` n) (len - n)

bundled/Data/ByteArray/Methods.hs

@@ -0,0 +1,312 @@
+-- |
+-- Module      : Data.ByteArray.Methods
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+module Data.ByteArray.Methods
+    ( alloc
+    , allocAndFreeze
+    , create
+    , unsafeCreate
+    , pack
+    , unpack
+    , uncons
+    , empty
+    , singleton
+    , cons
+    , snoc
+    , null
+    , replicate
+    , zero
+    , copy
+    , take
+    , drop
+    , span
+    , reverse
+    , convert
+    , copyRet
+    , copyAndFreeze
+    , splitAt
+    , xor
+    , index
+    , eq
+    , constEq
+    , any
+    , all
+    , append
+    , concat
+    ) where
+
+import           Data.ByteArray.Types
+import           Data.Memory.Internal.Compat
+import           Data.Memory.Internal.Imports hiding (empty)
+import           Data.Memory.PtrMethods
+import           Data.Monoid
+import           Foreign.Storable
+import           Foreign.Ptr
+
+import           Prelude hiding (length, take, drop, span, reverse, concat, replicate, splitAt, null, pred, last, any, all)
+import qualified Prelude
+
+#if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT)
+import qualified Data.ByteString as SPE (ByteString)
+import qualified Basement.UArray as SPE (UArray)
+import qualified Basement.Block  as SPE (Block)
+#endif
+
+-- | Allocate a new bytearray of specific size, and run the initializer on this memory
+alloc :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
+alloc n f
+    | n < 0     = alloc 0 f
+    | otherwise = snd `fmap` allocRet n f
+{-# INLINE alloc #-}
+
+-- | Allocate a new bytearray of specific size, and run the initializer on this memory
+create :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
+create n f = alloc n f
+
+-- | similar to 'alloc' but hide the allocation and initializer in a pure context
+allocAndFreeze :: ByteArray a => Int -> (Ptr p -> IO ()) -> a
+allocAndFreeze sz f = unsafeDoIO (alloc sz f)
+{-# NOINLINE allocAndFreeze #-}
+
+-- | similar to 'create' but hide the allocation and initializer in a pure context
+unsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a
+unsafeCreate sz f = unsafeDoIO (alloc sz f)
+{-# NOINLINE unsafeCreate #-}
+
+inlineUnsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a
+inlineUnsafeCreate !sz f = unsafeDoIO (alloc sz f)
+{-# INLINE inlineUnsafeCreate #-}
+
+-- | Create an empty byte array
+empty :: ByteArray a => a
+empty = unsafeDoIO (alloc 0 $ \_ -> return ())
+
+-- | Check if a byte array is empty
+null :: ByteArrayAccess a => a -> Bool
+null b = length b == 0
+
+-- | Pack a list of bytes into a bytearray
+pack :: ByteArray a => [Word8] -> a
+pack l = inlineUnsafeCreate (Prelude.length l) (fill l)
+  where fill []     _  = return ()
+        fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1)
+        {-# INLINE fill #-}
+{-# NOINLINE pack #-}
+
+-- | Un-pack a bytearray into a list of bytes
+unpack :: ByteArrayAccess a => a -> [Word8]
+unpack bs = loop 0
+  where !len = length bs
+        loop i
+            | i == len  = []
+            | otherwise =
+                let !v = unsafeDoIO $ withByteArray bs (\p -> peekByteOff p i)
+                 in v : loop (i+1)
+
+-- | returns the first byte, and the remaining bytearray if the bytearray is not null
+uncons :: ByteArray a => a -> Maybe (Word8, a)
+uncons a
+    | null a    = Nothing
+    | otherwise = Just (index a 0, drop 1 a)
+
+-- | Create a byte array from a single byte
+singleton :: ByteArray a => Word8 -> a
+singleton b = unsafeCreate 1 (\p -> pokeByteOff p 0 b)
+
+-- | prepend a single byte to a byte array
+cons :: ByteArray a => Word8 -> a -> a
+cons b ba = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do
+    pokeByteOff d 0 b
+    memCopy (d `plusPtr` 1) s len
+  where len = length ba
+
+-- | append a single byte to a byte array
+snoc :: ByteArray a =>  a -> Word8 -> a
+snoc ba b = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do
+    memCopy d s len
+    pokeByteOff d len b
+  where len = length ba
+
+-- | Create a xor of bytes between a and b.
+--
+-- the returns byte array is the size of the smallest input.
+xor :: (ByteArrayAccess a, ByteArrayAccess b, ByteArray c) => a -> b -> c
+xor a b =
+    unsafeCreate n $ \pc ->
+    withByteArray a  $ \pa ->
+    withByteArray b  $ \pb ->
+        memXor pc pa pb n
+  where
+        n  = min la lb
+        la = length a
+        lb = length b
+
+-- | return a specific byte indexed by a number from 0 in a bytearray
+--
+-- unsafe, no bound checking are done
+index :: ByteArrayAccess a => a -> Int -> Word8
+index b i = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i)
+
+-- | Split a bytearray at a specific length in two bytearray
+splitAt :: ByteArray bs => Int -> bs -> (bs, bs)
+splitAt n bs
+    | n <= 0    = (empty, bs)
+    | n >= len  = (bs, empty)
+    | otherwise = unsafeDoIO $ do
+        withByteArray bs $ \p -> do
+            b1 <- alloc n $ \r -> memCopy r p n
+            b2 <- alloc (len - n) $ \r -> memCopy r (p `plusPtr` n) (len - n)
+            return (b1, b2)
+  where len = length bs
+
+-- | Take the first @n@ byte of a bytearray
+take :: ByteArray bs => Int -> bs -> bs
+take n bs
+    | n <= 0    = empty
+    | otherwise = unsafeCreate m $ \d -> withByteArray bs $ \s -> memCopy d s m
+  where
+    !m   = min len n
+    !len = length bs
+
+-- | drop the first @n@ byte of a bytearray
+drop :: ByteArray bs => Int -> bs -> bs
+drop n bs
+    | n <= 0    = bs
+    | nb == 0   = empty
+    | otherwise = unsafeCreate nb $ \d -> withByteArray bs $ \s -> memCopy d (s `plusPtr` ofs) nb
+  where
+    ofs = min len n
+    nb  = len - ofs
+    len = length bs
+
+-- | Split a bytearray at the point where @pred@ becomes invalid
+span :: ByteArray bs => (Word8 -> Bool) -> bs -> (bs, bs)
+span pred bs
+    | null bs   = (bs, bs)
+    | otherwise = let n = loop 0 in (take n bs, drop n bs)
+  where loop !i
+            | i >= len          = len
+            | pred (index bs i) = loop (i+1)
+            | otherwise         = i
+        len = length bs
+
+-- | Reverse a bytearray
+reverse :: ByteArray bs => bs -> bs
+reverse bs = unsafeCreate n $ \d -> withByteArray bs $ \s -> memReverse d s n
+  where n = length bs
+
+-- | Concatenate bytearray into a larger bytearray
+concat :: (ByteArrayAccess bin, ByteArray bout) => [bin] -> bout
+concat l = unsafeCreate retLen (loopCopy l)
+  where
+    retLen = sum $ map length l
+
+    loopCopy []     _   = return ()
+    loopCopy (x:xs) dst = do
+        copyByteArrayToPtr x dst
+        loopCopy xs (dst `plusPtr` chunkLen)
+      where
+        !chunkLen = length x
+
+-- | append one bytearray to the other
+append :: ByteArray bs => bs -> bs -> bs
+append = mappend
+
+-- | Duplicate a bytearray into another bytearray, and run an initializer on it
+copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2
+copy bs f =
+    alloc (length bs) $ \d -> do
+        copyByteArrayToPtr bs d
+        f (castPtr d)
+
+-- | Similar to 'copy' but also provide a way to return a value from the initializer
+copyRet :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2)
+copyRet bs f =
+    allocRet (length bs) $ \d -> do
+        copyByteArrayToPtr bs d
+        f (castPtr d)
+
+-- | Similiar to 'copy' but expect the resulting bytearray in a pure context
+copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2
+copyAndFreeze bs f =
+    inlineUnsafeCreate (length bs) $ \d -> do
+        copyByteArrayToPtr bs d
+        f (castPtr d)
+{-# NOINLINE copyAndFreeze #-}
+
+-- | Create a bytearray of a specific size containing a repeated byte value
+replicate :: ByteArray ba => Int -> Word8 -> ba
+replicate 0 _ = empty
+replicate n b
+    | n < 0     = empty
+    | otherwise = inlineUnsafeCreate n $ \ptr -> memSet ptr b n
+{-# NOINLINE replicate #-}
+
+-- | Create a bytearray of a specific size initialized to 0
+zero :: ByteArray ba => Int -> ba
+zero 0 = empty
+zero n
+    | n < 0     = empty
+    | otherwise = unsafeCreate n $ \ptr -> memSet ptr 0 n
+{-# NOINLINE zero #-}
+
+-- | Check if two bytearray are equals
+--
+-- This is not constant time, as soon some byte differs the function will
+-- returns. use 'constEq' in sensitive context where timing matters.
+eq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool
+eq b1 b2
+    | l1 /= l2  = False
+    | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memEqual p1 p2 l1
+  where
+    l1 = length b1
+    l2 = length b2
+
+-- | A constant time equality test for 2 ByteArrayAccess values.
+--
+-- If values are of 2 different sizes, the function will abort early
+-- without comparing any bytes.
+--
+-- compared to == , this function will go over all the bytes
+-- present before yielding a result even when knowing the
+-- overall result early in the processing.
+constEq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool
+constEq b1 b2
+    | l1 /= l2  = False
+    | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memConstEqual p1 p2 l1
+  where
+    !l1 = length b1
+    !l2 = length b2
+
+-- | Check if any element of a byte array satisfies a predicate
+any :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool
+any f b
+    | null b    = False
+    | otherwise = unsafeDoIO $ withByteArray b $ \p -> loop p 0
+  where
+    len = length b
+    loop p i
+        | i == len  = return False
+        | otherwise = do
+            w <- peekByteOff p i
+            if f w then return True else loop p (i+1)
+
+-- | Check if all elements of a byte array satisfy a predicate
+all :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool
+all f b = not (any (not . f) b)
+
+-- | Convert a bytearray to another type of bytearray
+convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout
+convert bs = inlineUnsafeCreate (length bs) (copyByteArrayToPtr bs)
+#if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT)
+{-# SPECIALIZE convert :: SPE.ByteString -> SPE.UArray Word8 #-}
+{-# SPECIALIZE convert :: SPE.UArray Word8 -> SPE.ByteString #-}
+{-# SPECIALIZE convert :: SPE.ByteString -> SPE.Block Word8 #-}
+{-# SPECIALIZE convert :: SPE.Block Word8 -> SPE.ByteString #-}
+#endif

bundled/Data/ByteArray/Pack.hs

@@ -0,0 +1,145 @@
+-- |
+-- Module      : Data.ByteArray.Pack
+-- License     : BSD-Style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Simple Byte Array packer
+--
+-- Simple example:
+--
+-- > > flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32)
+-- > Right (ABCD *\NUL\NUL\NUL")
+--
+-- Original code from <https://hackage.haskell.org/package/bspack>
+-- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05)
+-- Copyright (c) 2014 Nicolas DI PRIMA
+--
+module Data.ByteArray.Pack
+    ( Packer
+    , Result(..)
+    , fill
+    , pack
+      -- * Operations
+      -- ** put
+    , putWord8
+    , putWord16
+    , putWord32
+    , putStorable
+    , putBytes
+    , fillList
+    , fillUpWith
+      -- ** skip
+    , skip
+    , skipStorable
+    ) where
+
+import           Data.Word
+import           Foreign.Ptr
+import           Foreign.Storable
+import           Data.Memory.Internal.Imports ()
+import           Data.Memory.Internal.Compat
+import           Data.Memory.PtrMethods
+import           Data.ByteArray.Pack.Internal
+import           Data.ByteArray (ByteArray, ByteArrayAccess, MemView(..))
+import qualified Data.ByteArray as B
+
+-- | Fill a given sized buffer with the result of the Packer action
+fill :: ByteArray byteArray => Int -> Packer a -> Either String byteArray
+fill len packing = unsafeDoIO $ do
+    (val, out) <- B.allocRet len $ \ptr -> runPacker_ packing (MemView ptr len)
+    case val of 
+        PackerMore _ (MemView _ r)
+            | r == 0    -> return $ Right out
+            | otherwise -> return $ Left ("remaining unpacked bytes " ++ show r ++ " at the end of buffer")
+        PackerFail err  -> return $ Left err
+
+-- | Pack the given packer into the given bytestring
+pack :: ByteArray byteArray => Packer a -> Int -> Either String byteArray
+pack packing len = fill len packing
+{-# DEPRECATED pack "use fill instead" #-}
+
+fillUpWithWord8' :: Word8 -> Packer ()
+fillUpWithWord8' w = Packer $ \(MemView ptr size) -> do
+    memSet ptr w size
+    return $ PackerMore () (MemView (ptr `plusPtr` size) 0)
+
+-- | Put a storable from the current position in the stream
+putStorable :: Storable storable => storable -> Packer ()
+putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s)
+
+-- | Put a Byte Array from the current position in the stream
+--
+-- If the ByteArray is null, then do nothing
+putBytes :: ByteArrayAccess ba => ba -> Packer ()
+putBytes bs
+    | neededLength == 0 = return ()
+    | otherwise         =
+        actionPacker neededLength $ \dstPtr -> B.withByteArray bs $ \srcPtr ->
+            memCopy dstPtr srcPtr neededLength
+  where
+    neededLength = B.length bs
+
+-- | Skip some bytes from the current position in the stream
+skip :: Int -> Packer ()
+skip n = actionPacker n (\_ -> return ())
+
+-- | Skip the size of a storable from the current position in the stream
+skipStorable :: Storable storable => storable -> Packer ()
+skipStorable = skip . sizeOf
+
+-- | Fill up from the current position in the stream to the end
+--
+-- It is equivalent to:
+--
+-- > fillUpWith s == fillList (repeat s)
+--
+fillUpWith :: Storable storable => storable -> Packer ()
+fillUpWith s = fillList $ repeat s
+{-# RULES "fillUpWithWord8" forall s . fillUpWith s = fillUpWithWord8' s #-}
+{-# NOINLINE fillUpWith #-}
+
+-- | Will put the given storable list from the current position in the stream
+-- to the end.
+--
+-- This function will fail with not enough storage if the given storable can't
+-- be written (not enough space)
+--
+-- Example:
+--
+-- > > pack (fillList $ [1..] :: Word8) 9
+-- > "\1\2\3\4\5\6\7\8\9"
+-- > > pack (fillList $ [1..] :: Word32) 4
+-- > "\1\0\0\0"
+-- > > pack (fillList $ [1..] :: Word32) 64
+-- > .. <..succesful..>
+-- > > pack (fillList $ [1..] :: Word32) 1
+-- > .. <.. not enough space ..>
+-- > > pack (fillList $ [1..] :: Word32) 131
+-- > .. <.. not enough space ..>
+--
+fillList :: Storable storable => [storable] -> Packer ()
+fillList []     = return ()
+fillList (x:xs) = putStorable x >> fillList xs
+
+------------------------------------------------------------------------------
+-- Common packer                                                            --
+------------------------------------------------------------------------------
+
+-- | put Word8 in the current position in the stream
+putWord8 :: Word8 -> Packer ()
+putWord8 = putStorable
+{-# INLINE putWord8 #-}
+
+-- | put Word16 in the current position in the stream
+-- /!\ use Host Endianness
+putWord16 :: Word16 -> Packer ()
+putWord16 = putStorable
+{-# INLINE putWord16 #-}
+
+-- | put Word32 in the current position in the stream
+-- /!\ use Host Endianness
+putWord32 :: Word32 -> Packer ()
+putWord32 = putStorable
+{-# INLINE putWord32 #-}

bundled/Data/ByteArray/Pack/Internal.hs

@@ -0,0 +1,88 @@
+-- |
+-- 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 (Show)
+
+-- | Simple ByteArray Packer
+newtype Packer a = Packer { runPacker_ :: MemView -> IO (Result a) }
+
+instance Functor Packer where
+    fmap = fmapPacker
+
+instance Applicative Packer where
+    pure  = returnPacker
+    (<*>) = appendPacker
+
+instance Monad Packer where
+    return = pure
+    (>>=)  = bindPacker
+
+fmapPacker :: (a -> b) -> Packer a -> Packer b
+fmapPacker f p = Packer $ \cache -> do
+    rv <- runPacker_ p cache
+    return $ case rv of
+        PackerMore v cache' -> PackerMore (f v) cache'
+        PackerFail err      -> PackerFail err
+{-# INLINE fmapPacker #-}
+
+returnPacker :: a -> Packer a
+returnPacker v = Packer $ \cache -> return $ PackerMore v cache
+{-# INLINE returnPacker #-}
+
+bindPacker :: Packer a -> (a -> Packer b) -> Packer b
+bindPacker p fp = Packer $ \cache -> do
+    rv <- runPacker_ p cache
+    case rv of
+        PackerMore v cache' -> runPacker_ (fp v) cache'
+        PackerFail err      -> return $ PackerFail err
+{-# INLINE bindPacker #-}
+
+appendPacker :: Packer (a -> b) -> Packer a -> Packer b
+appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)
+{-# INLINE appendPacker #-}
+
+-- | run a sized action
+actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a
+actionPacker s action = Packer $ \m@(MemView ptr size) ->
+    case compare size s of
+        LT -> return $ PackerFail "Not enough space in destination"
+        _  -> do
+            v <- action ptr
+            return $ PackerMore v (m `memViewPlus` s)
+{-# INLINE actionPacker #-}
+
+-- | run a sized action
+actionPackerWithRemain :: Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a
+actionPackerWithRemain s action = Packer $ \m@(MemView ptr size) ->
+    case compare size s of
+        LT -> return $ PackerFail "Not enough space in destination"
+        _  -> do
+            (remain, v) <- action ptr size
+            return $ if remain > s
+                then PackerFail "remaining bytes higher than the destination's size"
+                else PackerMore v (m `memViewPlus` (s+remain))
+{-# INLINE actionPackerWithRemain #-}

bundled/Data/ByteArray/Parse.hs

@@ -0,0 +1,258 @@
+-- |
+-- Module      : Data.ByteArray.Parse
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A very simple bytearray parser related to Parsec and Attoparsec
+--
+-- Simple example:
+--
+-- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest"
+-- > ParseOK "est" ("xx", 116)
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Data.ByteArray.Parse
+    ( Parser
+    , Result(..)
+    -- * run the Parser
+    , parse
+    , parseFeed
+    -- * Parser methods
+    , hasMore
+    , byte
+    , anyByte
+    , bytes
+    , take
+    , takeWhile
+    , takeAll
+    , skip
+    , skipWhile
+    , skipAll
+    , takeStorable
+    ) where
+
+import           Control.Monad
+import qualified Control.Monad.Fail as Fail
+import           Foreign.Storable              (Storable, peek, sizeOf)
+import           Data.Word
+
+import           Data.Memory.Internal.Imports
+import           Data.Memory.Internal.Compat
+import           Data.ByteArray.Types          (ByteArrayAccess, ByteArray)
+import qualified Data.ByteArray.Types     as B
+import qualified Data.ByteArray.Methods   as B
+
+import           Prelude hiding (take, takeWhile)
+
+-- | Simple parsing result, that represent respectively:
+--
+-- * failure: with the error message
+--
+-- * continuation: that need for more input data
+--
+-- * success: the remaining unparsed data and the parser value
+data Result byteArray a =
+      ParseFail String
+    | ParseMore (Maybe byteArray -> Result byteArray a)
+    | ParseOK   byteArray a
+
+instance (Show ba, Show a) => Show (Result ba a) where
+    show (ParseFail err) = "ParseFailure: " ++ err
+    show (ParseMore _)   = "ParseMore _"
+    show (ParseOK b a)   = "ParseOK " ++ show a ++ " " ++ show b
+
+-- | The continuation of the current buffer, and the error string
+type Failure byteArray r = byteArray -> String -> Result byteArray r
+
+-- | The continuation of the next buffer value, and the parsed value
+type Success byteArray a r = byteArray -> a -> Result byteArray r
+
+-- | Simple ByteString parser structure
+newtype Parser byteArray a = Parser
+    { runParser :: forall r . byteArray
+                           -> Failure byteArray r
+                           -> Success byteArray a r
+                           -> Result byteArray r }
+
+instance Functor (Parser byteArray) where
+    fmap f p = Parser $ \buf err ok ->
+        runParser p buf err (\b a -> ok b (f a))
+instance Applicative (Parser byteArray) where
+    pure v    = Parser $ \buf _ ok -> ok buf v
+    (<*>) d e = d >>= \b -> e >>= \a -> return (b a)
+instance Monad (Parser byteArray) where
+#if !(MIN_VERSION_base(4,13,0))
+    fail          = Fail.fail
+#endif
+    return        = pure
+    m >>= k       = Parser $ \buf err ok ->
+         runParser m buf err (\buf' a -> runParser (k a) buf' err ok)
+instance Fail.MonadFail (Parser byteArray) where
+    fail errorMsg = Parser $ \buf err _ -> err buf ("Parser failed: " ++ errorMsg)
+instance MonadPlus (Parser byteArray) where
+    mzero = fail "MonadPlus.mzero"
+    mplus f g = Parser $ \buf err ok ->
+        -- rewrite the err callback of @f to call @g
+        runParser f buf (\_ _ -> runParser g buf err ok) ok
+instance Alternative (Parser byteArray) where
+    empty = fail "Alternative.empty"
+    (<|>) = mplus
+
+-- | Run a parser on an @initial byteArray.
+--
+-- If the Parser need more data than available, the @feeder function
+-- is automatically called and fed to the More continuation.
+parseFeed :: (ByteArrayAccess byteArray, Monad m)
+          => m (Maybe byteArray)
+          -> Parser byteArray a
+          -> byteArray
+          -> m (Result byteArray a)
+parseFeed feeder p initial = loop $ parse p initial
+  where loop (ParseMore k) = feeder >>= (loop . k)
+        loop r             = return r
+
+-- | Run a Parser on a ByteString and return a 'Result'
+parse :: ByteArrayAccess byteArray
+      => Parser byteArray a -> byteArray -> Result byteArray a
+parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a)
+
+------------------------------------------------------------
+
+-- When needing more data, getMore append the next data
+-- to the current buffer. if no further data, then
+-- the err callback is called.
+getMore :: ByteArray byteArray => Parser byteArray ()
+getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
+    case nextChunk of
+        Nothing -> err buf "EOL: need more data"
+        Just nc
+            | B.null nc -> runParser getMore buf err ok
+            | otherwise -> ok (B.append buf nc) ()
+
+-- Only used by takeAll, which accumulate all the remaining data
+-- until ParseMore is fed a Nothing value.
+--
+-- getAll cannot fail.
+getAll :: ByteArray byteArray => Parser byteArray ()
+getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
+    case nextChunk of
+        Nothing -> ok buf ()
+        Just nc -> runParser getAll (B.append buf nc) err ok
+
+-- Only used by skipAll, which flush all the remaining data
+-- until ParseMore is fed a Nothing value.
+--
+-- flushAll cannot fail.
+flushAll :: ByteArray byteArray => Parser byteArray ()
+flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
+    case nextChunk of
+        Nothing -> ok buf ()
+        Just _  -> runParser flushAll B.empty err ok
+
+------------------------------------------------------------
+hasMore :: ByteArray byteArray => Parser byteArray Bool
+hasMore = Parser $ \buf err ok ->
+    if B.null buf
+        then ParseMore $ \nextChunk ->
+                case nextChunk of
+                    Nothing -> ok buf False
+                    Just nc -> runParser hasMore nc err ok
+        else ok buf True
+
+-- | Get the next byte from the parser
+anyByte :: ByteArray byteArray => Parser byteArray Word8
+anyByte = Parser $ \buf err ok ->
+    case B.uncons buf of
+        Nothing      -> runParser (getMore >> anyByte) buf err ok
+        Just (c1,b2) -> ok b2 c1
+
+-- | Parse a specific byte at current position
+--
+-- if the byte is different than the expected on,
+-- this parser will raise a failure.
+byte :: ByteArray byteArray => Word8 -> Parser byteArray ()
+byte w = Parser $ \buf err ok ->
+    case B.uncons buf of
+        Nothing      -> runParser (getMore >> byte w) buf err ok
+        Just (c1,b2) | c1 == w   -> ok b2 ()
+                     | otherwise -> err buf ("byte " ++ show w ++ " : failed : got " ++ show c1)
+
+-- | Parse a sequence of bytes from current position
+--
+-- if the following bytes don't match the expected
+-- bytestring completely, the parser will raise a failure
+bytes :: (Show ba, Eq ba, ByteArray ba) => ba -> Parser ba ()
+bytes allExpected = consumeEq allExpected
+  where errMsg = "bytes " ++ show allExpected ++ " : failed"
+
+        -- partially consume as much as possible or raise an error.
+        consumeEq expected = Parser $ \actual err ok ->
+            let eLen = B.length expected in
+            if B.length actual >= eLen
+                then    -- enough data for doing a full match
+                        let (aMatch,aRem) = B.splitAt eLen actual
+                         in if aMatch == expected
+                                then ok aRem ()
+                                else err actual errMsg
+                else    -- not enough data, match as much as we have, and then recurse.
+                        let (eMatch, eRem) = B.splitAt (B.length actual) expected
+                         in if actual == eMatch
+                                then runParser (getMore >> consumeEq eRem) B.empty err ok
+                                else err actual errMsg
+
+------------------------------------------------------------
+
+-- | Take a storable from the current position in the stream
+takeStorable :: (ByteArray byteArray, Storable d)
+             => Parser byteArray d
+takeStorable = anyStorable undefined
+  where
+    anyStorable :: ByteArray byteArray => Storable d => d -> Parser byteArray d
+    anyStorable a = do
+        buf <- take (sizeOf a)
+        return $ unsafeDoIO $ B.withByteArray buf $ \ptr -> peek ptr
+
+-- | Take @n bytes from the current position in the stream
+take :: ByteArray byteArray => Int -> Parser byteArray byteArray
+take n = Parser $ \buf err ok ->
+    if B.length buf >= n
+        then let (b1,b2) = B.splitAt n buf in ok b2 b1
+        else runParser (getMore >> take n) buf err ok
+
+-- | Take bytes while the @predicate hold from the current position in the stream
+takeWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray byteArray
+takeWhile predicate = Parser $ \buf err ok ->
+    let (b1, b2) = B.span predicate buf
+     in if B.null b2
+            then runParser (getMore >> takeWhile predicate) buf err ok
+            else ok b2 b1
+
+-- | Take the remaining bytes from the current position in the stream
+takeAll :: ByteArray byteArray => Parser byteArray byteArray
+takeAll = Parser $ \buf err ok ->
+    runParser (getAll >> returnBuffer) buf err ok
+  where
+    returnBuffer = Parser $ \buf _ ok -> ok B.empty buf
+
+-- | Skip @n bytes from the current position in the stream
+skip :: ByteArray byteArray => Int -> Parser byteArray ()
+skip n = Parser $ \buf err ok ->
+    if B.length buf >= n
+        then ok (B.drop n buf) ()
+        else runParser (getMore >> skip (n - B.length buf)) B.empty err ok
+
+-- | Skip bytes while the @predicate hold from the current position in the stream
+skipWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray ()
+skipWhile p = Parser $ \buf err ok ->
+    let (_, b2) = B.span p buf 
+     in if B.null b2
+            then runParser (getMore >> skipWhile p) B.empty err ok
+            else ok b2 ()
+
+-- | Skip all the remaining bytes from the current position in the stream
+skipAll :: ByteArray byteArray => Parser byteArray ()
+skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok

bundled/Data/ByteArray/ScrubbedBytes.hs

@@ -0,0 +1,205 @@
+-- |
+-- Module      : Data.ByteArray.ScrubbedBytes
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : Stable
+-- Portability : GHC
+--
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Data.ByteArray.ScrubbedBytes
+    ( ScrubbedBytes
+    ) where
+
+import           GHC.Types
+import           GHC.Prim
+import           GHC.Ptr
+import           GHC.Word
+#if MIN_VERSION_base(4,15,0)
+import           GHC.Exts (unsafeCoerce#)
+#endif
+#if MIN_VERSION_base(4,9,0)
+import           Data.Semigroup
+import           Data.Foldable (toList)
+#else
+import           Data.Monoid
+#endif
+import           Data.String (IsString(..))
+import           Data.Typeable
+import           Data.Memory.PtrMethods
+import           Data.Memory.Internal.CompatPrim
+import           Data.Memory.Internal.Compat     (unsafeDoIO)
+import           Data.Memory.Internal.Imports
+import           Data.ByteArray.Types
+import           Foreign.Storable
+#ifdef MIN_VERSION_basement
+import           Basement.NormalForm
+#endif
+
+-- | ScrubbedBytes is a memory chunk which have the properties of:
+--
+-- * Being scrubbed after its goes out of scope.
+--
+-- * A Show instance that doesn't actually show any content
+--
+-- * A Eq instance that is constant time
+--
+data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld)
+  deriving (Typeable)
+
+instance Show ScrubbedBytes where
+    show _ = "<scrubbed-bytes>"
+
+instance Eq ScrubbedBytes where
+    (==) = scrubbedBytesEq
+instance Ord ScrubbedBytes where
+    compare = scrubbedBytesCompare
+#if MIN_VERSION_base(4,9,0)
+instance Semigroup ScrubbedBytes where
+    b1 <> b2      = unsafeDoIO $ scrubbedBytesAppend b1 b2
+    sconcat       = unsafeDoIO . scrubbedBytesConcat . toList
+#endif
+instance Monoid ScrubbedBytes where
+    mempty        = unsafeDoIO (newScrubbedBytes 0)
+#if !(MIN_VERSION_base(4,11,0))
+    mappend b1 b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2
+    mconcat       = unsafeDoIO . scrubbedBytesConcat
+#endif
+instance NFData ScrubbedBytes where
+    rnf b = b `seq` ()
+#ifdef MIN_VERSION_basement
+instance NormalForm ScrubbedBytes where
+    toNormalForm b = b `seq` ()
+#endif
+instance IsString ScrubbedBytes where
+    fromString = scrubbedFromChar8
+
+instance ByteArrayAccess ScrubbedBytes where
+    length        = sizeofScrubbedBytes
+    withByteArray = withPtr
+
+instance ByteArray ScrubbedBytes where
+    allocRet = scrubbedBytesAllocRet
+
+newScrubbedBytes :: Int -> IO ScrubbedBytes
+newScrubbedBytes (I# sz)
+    | booleanPrim (sz <# 0#)  = error "ScrubbedBytes: size must be >= 0"
+    | booleanPrim (sz ==# 0#) = IO $ \s ->
+        case newAlignedPinnedByteArray# 0# 8# s of
+            (# s2, mba #) -> (# s2, ScrubbedBytes mba #)
+    | otherwise               = IO $ \s ->
+        case newAlignedPinnedByteArray# sz 8# s of
+            (# s1, mbarr #) ->
+                let !scrubber = getScrubber (byteArrayContents# (unsafeCoerce# mbarr))
+                    !mba      = ScrubbedBytes mbarr
+                 in case mkWeak# mbarr () (finalize scrubber mba) s1 of
+                    (# s2, _ #) -> (# s2, mba #)
+  where
+    getScrubber :: Addr# -> State# RealWorld -> State# RealWorld
+    getScrubber addr s =
+        let IO scrubBytes = memSet (Ptr addr) 0 (I# sz)
+         in case scrubBytes s of
+                (# s', _ #) -> s'
+
+#if __GLASGOW_HASKELL__ >= 800
+    finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> (# State# RealWorld, () #)
+    finalize scrubber mba@(ScrubbedBytes _) = \s1 ->
+        case scrubber s1 of
+            s2 -> case touch# mba s2 of
+                    s3 -> (# s3, () #)
+#else
+    finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> IO ()
+    finalize scrubber mba@(ScrubbedBytes _) = IO $ \s1 -> do
+        case scrubber s1 of
+            s2 -> case touch# mba s2 of
+                    s3 -> (# s3, () #)
+#endif
+
+scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes)
+scrubbedBytesAllocRet sz f = do
+    ba <- newScrubbedBytes sz
+    r  <- withPtr ba f
+    return (r, ba)
+
+scrubbedBytesAlloc :: Int -> (Ptr p -> IO ()) -> IO ScrubbedBytes
+scrubbedBytesAlloc sz f = do
+    ba <- newScrubbedBytes sz
+    withPtr ba f
+    return ba
+
+scrubbedBytesConcat :: [ScrubbedBytes] -> IO ScrubbedBytes
+scrubbedBytesConcat l = scrubbedBytesAlloc retLen (copy l)
+  where
+    retLen = sum $ map sizeofScrubbedBytes l
+
+    copy []     _   = return ()
+    copy (x:xs) dst = do
+        withPtr x $ \src -> memCopy dst src chunkLen
+        copy xs (dst `plusPtr` chunkLen)
+      where
+        chunkLen = sizeofScrubbedBytes x
+
+scrubbedBytesAppend :: ScrubbedBytes -> ScrubbedBytes -> IO ScrubbedBytes
+scrubbedBytesAppend b1 b2 = scrubbedBytesAlloc retLen $ \dst -> do
+    withPtr b1 $ \s1 -> memCopy dst                  s1 len1
+    withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2
+  where
+    len1   = sizeofScrubbedBytes b1
+    len2   = sizeofScrubbedBytes b2
+    retLen = len1 + len2
+
+
+sizeofScrubbedBytes :: ScrubbedBytes -> Int
+sizeofScrubbedBytes (ScrubbedBytes mba) = I# (sizeofMutableByteArray# mba)
+
+withPtr :: ScrubbedBytes -> (Ptr p -> IO a) -> IO a
+withPtr b@(ScrubbedBytes mba) f = do
+    a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba)))
+    touchScrubbedBytes b
+    return a
+
+touchScrubbedBytes :: ScrubbedBytes -> IO ()
+touchScrubbedBytes (ScrubbedBytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #)
+
+scrubbedBytesEq :: ScrubbedBytes -> ScrubbedBytes -> Bool
+scrubbedBytesEq a b
+    | l1 /= l2  = False
+    | otherwise = unsafeDoIO $ withPtr a $ \p1 -> withPtr b $ \p2 -> memConstEqual p1 p2 l1
+  where
+        l1 = sizeofScrubbedBytes a
+        l2 = sizeofScrubbedBytes b
+
+scrubbedBytesCompare :: ScrubbedBytes -> ScrubbedBytes -> Ordering
+scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ loop 0
+  where
+    !l1  = sizeofScrubbedBytes b1
+    !l2  = sizeofScrubbedBytes b2
+    !len = min l1 l2
+
+    loop !i
+        | i == len =
+            if l1 == l2
+                then pure EQ
+                else if l1 > l2 then pure GT
+                                else pure LT
+        | otherwise = do
+            e1 <- read8 m1 i
+            e2 <- read8 m2 i
+            if e1 == e2
+                then loop (i+1)
+                else if e1 < e2 then pure LT
+                                else pure GT
+
+    read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of
+                                    (# s2, e #) -> (# s2, W8# e #)
+
+scrubbedFromChar8 :: [Char] -> ScrubbedBytes
+scrubbedFromChar8 l = unsafeDoIO $ scrubbedBytesAlloc len (fill l)
+  where
+    len = Prelude.length l
+    fill :: [Char] -> Ptr Word8 -> IO ()
+    fill []     _  = return ()
+    fill (x:xs) !p = poke p (fromIntegral $ fromEnum x) >> fill xs (p `plusPtr` 1)

bundled/Data/ByteArray/Sized.hs

@@ -0,0 +1,398 @@
+-- |
+-- Module      : Data.ByteArray.Sized
+-- License     : BSD-style
+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
+-- Stability   : stable
+-- Portability : Good
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE NoStarIsType #-}
+#endif
+
+module Data.ByteArray.Sized
+    ( ByteArrayN(..)
+    , SizedByteArray
+    , unSizedByteArray
+    , sizedByteArray
+    , unsafeSizedByteArray
+
+    , -- * ByteArrayN operators
+      alloc
+    , create
+    , allocAndFreeze
+    , unsafeCreate
+    , inlineUnsafeCreate
+    , empty
+    , pack
+    , unpack
+    , cons
+    , snoc
+    , xor
+    , index
+    , splitAt
+    , take
+    , drop
+    , append
+    , copy
+    , copyRet
+    , copyAndFreeze
+    , replicate
+    , zero
+    , convert
+    , fromByteArrayAccess
+    , unsafeFromByteArrayAccess
+    ) where
+
+import Basement.Imports
+import Basement.NormalForm
+import Basement.Nat
+import Basement.Numerical.Additive ((+))
+import Basement.Numerical.Subtractive ((-))
+
+import Basement.Sized.List (ListN, unListN, toListN)
+
+import           Foreign.Storable
+import           Foreign.Ptr
+import           Data.Maybe (fromMaybe)
+
+import           Data.Memory.Internal.Compat
+import           Data.Memory.PtrMethods
+
+import Data.Proxy (Proxy(..))
+
+import Data.ByteArray.Types (ByteArrayAccess(..), ByteArray)
+import qualified Data.ByteArray.Types as ByteArray (allocRet)
+
+#if MIN_VERSION_basement(0,0,7)
+import           Basement.BlockN (BlockN)
+import qualified Basement.BlockN as BlockN
+import qualified Basement.PrimType as Base
+import           Basement.Types.OffsetSize (Countable)
+#endif
+
+-- | Type class to emulate exactly the behaviour of 'ByteArray' but with
+-- a known length at compile time
+--
+class (ByteArrayAccess c, KnownNat n) => ByteArrayN (n :: Nat) c | c -> n where
+    -- | just like 'allocRet' but with the size at the type level
+    allocRet :: forall p a
+              . Proxy n
+             -> (Ptr p -> IO a)
+             -> IO (a, c)
+
+-- | Wrapper around any collection type with the size as type parameter
+--
+newtype SizedByteArray (n :: Nat) ba = SizedByteArray { unSizedByteArray :: ba }
+  deriving (Eq, Show, Typeable, Ord, NormalForm)
+
+-- | create a 'SizedByteArray' from the given 'ByteArrayAccess' if the
+-- size is the same as the target size.
+--
+sizedByteArray :: forall n ba . (KnownNat n, ByteArrayAccess ba)
+               => ba
+               -> Maybe (SizedByteArray n ba)
+sizedByteArray ba
+    | length ba == n = Just $ SizedByteArray ba
+    | otherwise      = Nothing
+  where
+    n = fromInteger $ natVal (Proxy @n)
+
+-- | just like the 'sizedByteArray' function but throw an exception if
+-- the size is invalid.
+unsafeSizedByteArray :: forall n ba . (ByteArrayAccess ba, KnownNat n) => ba -> SizedByteArray n ba
+unsafeSizedByteArray = fromMaybe (error "The size is invalid") . sizedByteArray
+
+instance (ByteArrayAccess ba, KnownNat n) => ByteArrayAccess (SizedByteArray n ba) where
+    length _ = fromInteger $ natVal (Proxy @n)
+    withByteArray (SizedByteArray ba) = withByteArray ba
+
+instance (KnownNat n, ByteArray ba) => ByteArrayN n (SizedByteArray n ba) where
+    allocRet p f = do
+        (a, ba) <- ByteArray.allocRet n f
+        pure (a, SizedByteArray ba)
+      where
+        n = fromInteger $ natVal p
+
+#if MIN_VERSION_basement(0,0,7)
+instance ( ByteArrayAccess (BlockN n ty)
+         , PrimType ty
+         , KnownNat n
+         , Countable ty n
+         , KnownNat nbytes
+         , nbytes ~ (Base.PrimSize ty * n)
+         ) => ByteArrayN nbytes (BlockN n ty) where
+    allocRet _ f = do
+        mba <- BlockN.new @n
+        a   <- BlockN.withMutablePtrHint True False mba (f . castPtr)
+        ba  <- BlockN.freeze mba
+        return (a, ba)
+#endif
+
+
+-- | Allocate a new bytearray of specific size, and run the initializer on this memory
+alloc :: forall n ba p . (ByteArrayN n ba, KnownNat n)
+      => (Ptr p -> IO ())
+      -> IO ba
+alloc f = snd <$> allocRet (Proxy @n) f
+
+-- | Allocate a new bytearray of specific size, and run the initializer on this memory
+create :: forall n ba p . (ByteArrayN n ba, KnownNat n)
+       => (Ptr p -> IO ())
+       -> IO ba
+create = alloc @n
+{-# NOINLINE create #-}
+
+-- | similar to 'allocN' but hide the allocation and initializer in a pure context
+allocAndFreeze :: forall n ba p . (ByteArrayN n ba, KnownNat n)
+               => (Ptr p -> IO ()) -> ba
+allocAndFreeze f = unsafeDoIO (alloc @n f)
+{-# NOINLINE allocAndFreeze #-}
+
+-- | similar to 'createN' but hide the allocation and initializer in a pure context
+unsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n)
+             => (Ptr p -> IO ()) -> ba
+unsafeCreate f = unsafeDoIO (alloc @n f)
+{-# NOINLINE unsafeCreate #-}
+
+inlineUnsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n)
+                   => (Ptr p -> IO ()) -> ba
+inlineUnsafeCreate f = unsafeDoIO (alloc @n f)
+{-# INLINE inlineUnsafeCreate #-}
+
+-- | Create an empty byte array
+empty :: forall ba . ByteArrayN 0 ba => ba
+empty = unsafeDoIO (alloc @0 $ \_ -> return ())
+
+-- | Pack a list of bytes into a bytearray
+pack :: forall n ba . (ByteArrayN n ba, KnownNat n) => ListN n Word8 -> ba
+pack l = inlineUnsafeCreate @n (fill $ unListN l)
+  where fill []     _  = return ()
+        fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1)
+        {-# INLINE fill #-}
+{-# NOINLINE pack #-}
+
+-- | Un-pack a bytearray into a list of bytes
+unpack :: forall n ba
+        . (ByteArrayN n ba, KnownNat n, NatWithinBound Int n, ByteArrayAccess ba)
+       => ba -> ListN n Word8
+unpack bs =  fromMaybe (error "the impossible appened") $ toListN @n $ loop 0
+  where !len = length bs
+        loop i
+            | i == len  = []
+            | otherwise =
+                let !v = unsafeDoIO $ withByteArray bs (`peekByteOff` i)
+                 in v : loop (i+1)
+
+-- | prepend a single byte to a byte array
+cons :: forall ni no bi bo
+      . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi
+        , KnownNat ni, KnownNat no
+        , (ni + 1) ~ no
+        )
+     => Word8 -> bi -> bo
+cons b ba = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do
+    pokeByteOff d 0 b
+    memCopy (d `plusPtr` 1) s len
+  where
+    !len = fromInteger $ natVal (Proxy @ni)
+
+-- | append a single byte to a byte array
+snoc :: forall bi bo ni no
+      . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi
+        , KnownNat ni, KnownNat no
+        , (ni + 1) ~ no
+        )
+     => bi -> Word8 -> bo
+snoc ba b = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do
+    memCopy d s len
+    pokeByteOff d len b
+  where
+    !len = fromInteger $ natVal (Proxy @ni)
+
+-- | Create a xor of bytes between a and b.
+--
+-- the returns byte array is the size of the smallest input.
+xor :: forall n a b c
+     . ( ByteArrayN n a, ByteArrayN n b, ByteArrayN n c
+       , ByteArrayAccess a, ByteArrayAccess b
+       , KnownNat n
+       )
+    => a -> b -> c
+xor a b =
+    unsafeCreate @n $ \pc ->
+    withByteArray a  $ \pa ->
+    withByteArray b  $ \pb ->
+        memXor pc pa pb n
+  where
+    n  = fromInteger (natVal (Proxy @n))
+
+-- | return a specific byte indexed by a number from 0 in a bytearray
+--
+-- unsafe, no bound checking are done
+index :: forall n na ba
+       . ( ByteArrayN na ba, ByteArrayAccess ba
+         , KnownNat na, KnownNat n
+         , n <= na
+         )
+      => ba -> Proxy n -> Word8
+index b pi = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i)
+  where
+    i = fromInteger $ natVal pi
+
+-- | Split a bytearray at a specific length in two bytearray
+splitAt :: forall nblhs nbi nbrhs bi blhs brhs
+         . ( ByteArrayN nbi bi, ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs
+           , ByteArrayAccess bi
+           , KnownNat nbi, KnownNat nblhs, KnownNat nbrhs
+           , nblhs <= nbi, (nbrhs + nblhs) ~ nbi
+           )
+        => bi -> (blhs, brhs)
+splitAt bs = unsafeDoIO $
+    withByteArray bs $ \p -> do
+        b1 <- alloc @nblhs $ \r -> memCopy r p n
+        b2 <- alloc @nbrhs $ \r -> memCopy r (p `plusPtr` n) (len - n)
+        return (b1, b2)
+  where
+    n = fromInteger $ natVal (Proxy @nblhs)
+    len = length bs
+
+-- | Take the first @n@ byte of a bytearray
+take :: forall nbo nbi bi bo
+      . ( ByteArrayN nbi bi, ByteArrayN nbo bo
+        , ByteArrayAccess bi
+        , KnownNat nbi, KnownNat nbo
+        , nbo <= nbi
+        )
+     => bi -> bo
+take bs = unsafeCreate @nbo $ \d -> withByteArray bs $ \s -> memCopy d s m
+  where
+    !m   = min len n
+    !len = length bs
+    !n   = fromInteger $ natVal (Proxy @nbo)
+
+-- | drop the first @n@ byte of a bytearray
+drop :: forall n nbi nbo bi bo
+      . ( ByteArrayN nbi bi, ByteArrayN nbo bo
+        , ByteArrayAccess bi
+        , KnownNat n, KnownNat nbi, KnownNat nbo
+        , (nbo + n) ~ nbi
+        )
+     => Proxy n -> bi -> bo
+drop pn bs = unsafeCreate @nbo $ \d ->
+    withByteArray bs $ \s ->
+    memCopy d (s `plusPtr` ofs) nb
+  where
+    ofs = min len n
+    nb  = len - ofs
+    len = length bs
+    n   = fromInteger $ natVal pn
+
+-- | append one bytearray to the other
+append :: forall nblhs nbrhs nbout blhs brhs bout
+        . ( ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs, ByteArrayN nbout bout
+          , ByteArrayAccess blhs, ByteArrayAccess brhs
+          , KnownNat nblhs, KnownNat nbrhs, KnownNat nbout
+          , (nbrhs + nblhs) ~ nbout
+          )
+       => blhs -> brhs -> bout
+append blhs brhs = unsafeCreate @nbout $ \p ->
+    withByteArray blhs $ \plhs ->
+    withByteArray brhs $ \prhs -> do
+        memCopy p plhs (length blhs)
+        memCopy (p `plusPtr` length blhs) prhs (length brhs)
+
+-- | Duplicate a bytearray into another bytearray, and run an initializer on it
+copy :: forall n bs1 bs2 p
+      . ( ByteArrayN n bs1, ByteArrayN n bs2
+        , ByteArrayAccess bs1
+        , KnownNat n
+        )
+     => bs1 -> (Ptr p -> IO ()) -> IO bs2
+copy bs f = alloc @n $ \d -> do
+    withByteArray bs $ \s -> memCopy d s (length bs)
+    f (castPtr d)
+
+-- | Similar to 'copy' but also provide a way to return a value from the initializer
+copyRet :: forall n bs1 bs2 p a
+         . ( ByteArrayN n bs1, ByteArrayN n bs2
+           , ByteArrayAccess bs1
+           , KnownNat n
+           )
+        => bs1 -> (Ptr p -> IO a) -> IO (a, bs2)
+copyRet bs f =
+    allocRet (Proxy @n) $ \d -> do
+        withByteArray bs $ \s -> memCopy d s (length bs)
+        f (castPtr d)
+
+-- | Similiar to 'copy' but expect the resulting bytearray in a pure context
+copyAndFreeze :: forall n bs1 bs2 p
+               . ( ByteArrayN n bs1, ByteArrayN n bs2
+                 , ByteArrayAccess bs1
+                 , KnownNat n
+                 )
+              => bs1 -> (Ptr p -> IO ()) -> bs2
+copyAndFreeze bs f =
+    inlineUnsafeCreate @n $ \d -> do
+        copyByteArrayToPtr bs d
+        f (castPtr d)
+{-# NOINLINE copyAndFreeze #-}
+
+-- | Create a bytearray of a specific size containing a repeated byte value
+replicate :: forall n ba . (ByteArrayN n ba, KnownNat n)
+          => Word8 -> ba
+replicate b = inlineUnsafeCreate @n $ \ptr -> memSet ptr b (fromInteger $ natVal $ Proxy @n)
+{-# NOINLINE replicate #-}
+
+-- | Create a bytearray of a specific size initialized to 0
+zero :: forall n ba . (ByteArrayN n ba, KnownNat n) => ba
+zero = unsafeCreate @n $ \ptr -> memSet ptr 0 (fromInteger $ natVal $ Proxy @n)
+{-# NOINLINE zero #-}
+
+-- | Convert a bytearray to another type of bytearray
+convert :: forall n bin bout
+         . ( ByteArrayN n bin, ByteArrayN n bout
+           , KnownNat n
+           )
+        => bin -> bout
+convert bs = inlineUnsafeCreate @n (copyByteArrayToPtr bs)
+
+-- | Convert a ByteArrayAccess to another type of bytearray
+--
+-- This function returns nothing if the size is not compatible
+fromByteArrayAccess :: forall n bin bout
+                     . ( ByteArrayAccess bin, ByteArrayN n bout
+                       , KnownNat n
+                       )
+                    => bin -> Maybe bout
+fromByteArrayAccess bs
+    | l == n    = Just $ inlineUnsafeCreate @n (copyByteArrayToPtr bs)
+    | otherwise = Nothing
+  where
+    l = length bs
+    n = fromInteger $ natVal (Proxy @n)
+
+-- | Convert a ByteArrayAccess to another type of bytearray
+unsafeFromByteArrayAccess :: forall n bin bout
+                           . ( ByteArrayAccess bin, ByteArrayN n bout
+                             , KnownNat n
+                           )
+                          => bin -> bout
+unsafeFromByteArrayAccess bs = case fromByteArrayAccess @n @bin @bout bs of
+    Nothing -> error "Invalid Size"
+    Just v  -> v

bundled/Data/ByteArray/Types.hs

@@ -0,0 +1,133 @@
+-- |
+-- Module      : Data.ByteArray.Types
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Rank2Types    #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies  #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteArray.Types
+    ( ByteArrayAccess(..)
+    , ByteArray(..)
+    ) where
+
+import           Foreign.Ptr
+import           Data.Monoid
+
+#ifdef WITH_BYTESTRING_SUPPORT
+import qualified Data.ByteString as Bytestring (length)
+import qualified Data.ByteString.Internal as Bytestring
+import           Foreign.ForeignPtr (withForeignPtr)
+#endif
+
+import           Data.Memory.PtrMethods (memCopy)
+
+
+import           Data.Proxy (Proxy(..))
+import           Data.Word (Word8)
+
+import qualified Basement.Types.OffsetSize as Base
+import qualified Basement.UArray as Base
+import qualified Basement.String as Base (String, toBytes, Encoding(UTF8))
+
+import qualified Basement.UArray.Mutable as BaseMutable (withMutablePtrHint)
+import qualified Basement.Block as Block
+import qualified Basement.Block.Mutable as Block
+
+import           Basement.Nat
+import qualified Basement.Sized.Block as BlockN
+
+import Prelude hiding (length)
+
+-- | Class to Access size properties and data of a ByteArray
+class ByteArrayAccess ba where
+    -- | Return the length in bytes of a bytearray
+    length        :: ba -> Int
+    -- | Allow to use using a pointer
+    withByteArray :: ba -> (Ptr p -> IO a) -> IO a
+    -- | Copy the data of a bytearray to a ptr
+    copyByteArrayToPtr :: ba -> Ptr p -> IO ()
+    copyByteArrayToPtr a dst = withByteArray a $ \src -> memCopy (castPtr dst) src (length a)
+
+-- | Class to allocate new ByteArray of specific size
+class (Eq ba, Ord ba, Monoid ba, ByteArrayAccess ba) => ByteArray ba where
+    -- | allocate `n` bytes and perform the given operation
+    allocRet  :: Int
+                -- ^ number of bytes to allocate. i.e. might not match the
+                -- size of the given type `ba`.
+              -> (Ptr p -> IO a)
+              -> IO (a, ba)
+
+#ifdef WITH_BYTESTRING_SUPPORT
+instance ByteArrayAccess Bytestring.ByteString where
+    length = Bytestring.length
+    withByteArray (Bytestring.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off)
+
+instance ByteArray Bytestring.ByteString where
+    allocRet sz f = do
+        fptr <- Bytestring.mallocByteString sz
+        r    <- withForeignPtr fptr (f . castPtr)
+        return (r, Bytestring.PS fptr 0 sz)
+#endif
+
+#ifdef WITH_BASEMENT_SUPPORT
+
+baseBlockRecastW8 :: Base.PrimType ty => Block.Block ty -> Block.Block Word8
+baseBlockRecastW8 = Block.unsafeCast -- safe with Word8 destination
+
+instance Base.PrimType ty => ByteArrayAccess (Block.Block ty) where
+    length a = let Base.CountOf i = Block.length (baseBlockRecastW8 a) in i
+    withByteArray a f = Block.withPtr (baseBlockRecastW8 a) (f . castPtr)
+    copyByteArrayToPtr ba dst = do
+        mb <- Block.unsafeThaw (baseBlockRecastW8 ba)
+        Block.copyToPtr mb 0 (castPtr dst) (Block.length $ baseBlockRecastW8 ba)
+
+instance (KnownNat n, Base.PrimType ty, Base.Countable ty n) => ByteArrayAccess (BlockN.BlockN n ty) where
+    length a = let Base.CountOf i = BlockN.lengthBytes a in i
+    withByteArray a f = BlockN.withPtr a (f . castPtr)
+    copyByteArrayToPtr bna = copyByteArrayToPtr (BlockN.toBlock bna)
+
+baseUarrayRecastW8 :: Base.PrimType ty => Base.UArray ty -> Base.UArray Word8
+baseUarrayRecastW8 = Base.recast
+
+instance Base.PrimType ty => ByteArrayAccess (Base.UArray ty) where
+    length a = let Base.CountOf i = Base.length (baseUarrayRecastW8 a) in i
+    withByteArray a f = Base.withPtr (baseUarrayRecastW8 a) (f . castPtr)
+    copyByteArrayToPtr ba dst = Base.copyToPtr ba (castPtr dst)
+
+instance ByteArrayAccess Base.String where
+    length str = let Base.CountOf i = Base.length bytes in i
+      where
+        -- the Foundation's length return a number of elements not a number of
+        -- bytes. For @ByteArrayAccess@, because we are using an @Int@, we
+        -- didn't see that we were returning the wrong @CountOf@.
+        bytes = Base.toBytes Base.UTF8 str
+    withByteArray s f = withByteArray (Base.toBytes Base.UTF8 s) f
+
+instance (Ord ty, Base.PrimType ty) => ByteArray (Block.Block ty) where
+    allocRet sz f = do
+        mba <- Block.new $ sizeRecastBytes sz Proxy
+        a   <- Block.withMutablePtrHint True False mba (f . castPtr)
+        ba  <- Block.unsafeFreeze mba
+        return (a, ba)
+
+instance (Ord ty, Base.PrimType ty) => ByteArray (Base.UArray ty) where
+    allocRet sz f = do
+        mba <- Base.new $ sizeRecastBytes sz Proxy
+        a   <- BaseMutable.withMutablePtrHint True False mba (f . castPtr)
+        ba  <- Base.unsafeFreeze mba
+        return (a, ba)
+
+sizeRecastBytes :: Base.PrimType ty => Int -> Proxy ty -> Base.CountOf ty
+sizeRecastBytes w p = Base.CountOf $
+    let (q,r) = w `Prelude.quotRem` szTy
+     in q + (if r == 0 then 0 else 1)
+  where !(Base.CountOf szTy) = Base.primSizeInBytes p
+{-# INLINE [1] sizeRecastBytes #-}
+
+#endif

bundled/Data/ByteArray/View.hs

@@ -0,0 +1,128 @@
+-- |
+-- Module      : Data.ByteArray.View
+-- License     : BSD-style
+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>
+-- Stability   : stable
+-- Portability : Good
+--
+-- a View on a given ByteArrayAccess
+--
+
+module Data.ByteArray.View
+    ( View
+    , view
+    , takeView
+    , dropView
+    ) where
+
+import Data.ByteArray.Methods
+import Data.ByteArray.Types
+import Data.Memory.PtrMethods
+import Data.Memory.Internal.Compat
+import Foreign.Ptr (plusPtr)
+
+import Prelude hiding (length, take, drop)
+
+-- | a view on a given bytes
+--
+-- Equality test in constant time
+data View bytes = View
+    { viewOffset :: !Int
+    , viewSize   :: !Int
+    , unView     :: !bytes
+    }
+
+instance ByteArrayAccess bytes => Eq (View bytes) where
+    (==) = constEq
+
+instance ByteArrayAccess bytes => Ord (View bytes) where
+    compare v1 v2 = unsafeDoIO $
+        withByteArray v1 $ \ptr1 ->
+        withByteArray v2 $ \ptr2 -> do
+            ret <- memCompare ptr1 ptr2 (min (viewSize v1) (viewSize v2))
+            return $ case ret of
+                EQ | length v1 >  length v2 -> GT
+                   | length v1 <  length v2 -> LT
+                   | length v1 == length v2 -> EQ
+                _                           -> ret
+
+instance ByteArrayAccess bytes => Show (View bytes) where
+    showsPrec p v r = showsPrec p (viewUnpackChars v []) r
+
+instance ByteArrayAccess bytes => ByteArrayAccess (View bytes) where
+    length = viewSize
+    withByteArray v f = withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v))
+
+viewUnpackChars :: ByteArrayAccess bytes
+                => View bytes
+                -> String
+                -> String
+viewUnpackChars v xs = chunkLoop 0
+  where
+    len = length v
+
+    chunkLoop :: Int -> [Char]
+    chunkLoop idx
+        | len == idx = []
+        | (len - idx) > 63 =
+            bytesLoop idx (idx + 64) (chunkLoop (idx + 64))
+        | otherwise =
+            bytesLoop idx (len - idx) xs
+
+    bytesLoop :: Int -> Int -> [Char] -> [Char]
+    bytesLoop idx chunkLenM1 paramAcc =
+        loop (idx + chunkLenM1 - 1) paramAcc
+      where
+        loop i acc
+            | i == idx  = (rChar i : acc)
+            | otherwise = loop (i - 1) (rChar i : acc)
+
+    rChar :: Int -> Char
+    rChar idx = toEnum $ fromIntegral $ index v idx
+
+-- | create a view on a given bytearray
+--
+-- This function update the offset and the size in order to guarantee:
+--
+-- * offset >= 0
+-- * size >= 0
+-- * offset < length
+-- * size =< length - offset
+--
+view :: ByteArrayAccess bytes
+     => bytes -- ^ the byte array we put a view on
+     -> Int   -- ^ the offset to start the byte array on
+     -> Int   -- ^ the size of the view
+     -> View bytes
+view b offset'' size'' = View offset size b
+  where
+    -- make sure offset is not negative
+    offset' :: Int
+    offset' = max offset'' 0
+
+    -- make sure the offset is not out of bound
+    offset :: Int
+    offset = min offset' (length b - 1)
+
+    -- make sure length is not negative
+    size' :: Int
+    size' = max size'' 0
+
+    -- make sure the length is not out of the bound
+    size :: Int
+    size = min size' (length b - offset)
+
+-- | create a view from the given bytearray
+takeView :: ByteArrayAccess bytes
+         => bytes -- ^ byte aray
+         -> Int   -- ^ size of the view
+         -> View bytes
+takeView b size = view b 0 size
+
+-- | create a view from the given byte array
+-- starting after having dropped the fist n bytes
+dropView :: ByteArrayAccess bytes
+         => bytes -- ^ byte array
+         -> Int   -- ^ the number of bytes do dropped before creating the view
+         -> View bytes
+dropView b offset = view b offset (length b - offset)