memory 0.10 → 0.18.0
raw patch · 29 files changed
Files
- CHANGELOG.md +107/−0
- Data/ByteArray/Bytes.hs +62/−26
- Data/ByteArray/Encoding.hs +54/−4
- Data/ByteArray/Mapping.hs +7/−2
- Data/ByteArray/MemView.hs +1/−1
- Data/ByteArray/Methods.hs +44/−15
- Data/ByteArray/Pack.hs +23/−14
- Data/ByteArray/Pack/Internal.hs +1/−2
- Data/ByteArray/Parse.hs +62/−25
- Data/ByteArray/ScrubbedBytes.hs +80/−21
- Data/ByteArray/Sized.hs +398/−0
- Data/ByteArray/Types.hs +97/−10
- Data/Memory/Encoding/Base16.hs +25/−17
- Data/Memory/Encoding/Base32.hs +22/−19
- Data/Memory/Encoding/Base64.hs +23/−22
- Data/Memory/Hash/FNV.hs +49/−49
- Data/Memory/Hash/SipHash.hs +3/−1
- Data/Memory/Internal/CompatPrim.hs +1/−20
- Data/Memory/Internal/CompatPrim64.hs +2/−0
- Data/Memory/Internal/Imports.hs +1/−1
- Data/Memory/Internal/Scrubber.hs +0/−72
- Data/Memory/PtrMethods.hs +23/−8
- LICENSE +2/−1
- README.md +1/−19
- memory.cabal +33/−10
- tests/Imports.hs +6/−7
- tests/SipHash.hs +4/−3
- tests/Tests.hs +169/−66
- tests/Utils.hs +14/−0
CHANGELOG.md view
@@ -1,3 +1,110 @@+## 0.18++* drop support for ghc < 8.8+* compat with ghc 9.4++## ...++## 0.14.18++* Branch/Release Snafu++## 0.14.17++* Require basement >= 0.0.7, Fix compilation with GHC 8,6+* Cleanup CPP, dropping support for much older version++## 0.14.16++* Fix compilation with a newer basement (>= 0.0.7) and an older GHC (< 8.0)++## 0.14.15++* Convert tests to foundation checks+* Convert CI to haskell-ci+* Fix compilation without foundation+* Introduce ByteArrayL and associated method, as a type level sized version of ByteArray+* Add NormalForm for Bytes and ScrubbedBytes++## 0.14.14++* Fix bounds issues with empty strings in base64 and base32+* Improve tests compatibility w.r.t old basement version++## 0.14.13++* Handle compat SPECIALIZE for older GHC++## 0.14.12++* Optimise copy operations and convert+* Add instance of ByteArrayAccess and ByteArray for Block+* Add Block and UArray in memory's tests++## 0.14.11++* Fix issue in unBase64 with an empty bytestring that would cause a segfault++## 0.14.10++* Reintroduce foundation compatibility with old version++## 0.14.9++* Reduce dependency to basement++## 0.14.8++* Fix incompatibility with foundation 0.0.14++## 0.14.7++* Fix typo in state passing++## 0.14.6++* Fix allocRet using unit of bytes but using as unit of ty directly without adaptation++## 0.14.5++* Fix bug in memXorWith not working as advertised if source different from destination++## 0.14.4++* Add support for foundation uarray creation+* optimise memXorWith++## 0.14.3++* Add support for foundation uarray peeking++## 0.14.2++* Fix use of ghc 8.2 touch+* Prevent span from reading past buffer+* cleanup .prof spam++## 0.14.1++* Fix `Show` instance of Bytes (Oliver Chéron)++## 0.14++* Improve fromW64BE+* Add IsString instance for ScrubbedBytes++## 0.13++* Add combinator to check for end of parsing.++## 0.12++* Fix compilation with mkWeak and latest GHC (Lars Kuhtz)++## 0.11++* add support for GHC 8.0.1+ ## 0.10 * make memConstEqual more constant not using boolean comparaison
Data/ByteArray/Bytes.hs view
@@ -7,25 +7,44 @@ -- -- 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@@ -33,12 +52,23 @@ (==) = 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@@ -55,9 +85,11 @@ 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@@ -75,23 +107,23 @@ bytesConcat :: [Bytes] -> IO Bytes bytesConcat l = bytesAlloc retLen (copy l) where- retLen = sum $ map bytesLength l+ !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+ !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+ !len1 = bytesLength b1+ !len2 = bytesLength b2+ !retLen = len1 + len2 bytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, Bytes) bytesAllocRet sz f = do@@ -101,6 +133,7 @@ bytesLength :: Bytes -> Int bytesLength = sizeofBytes+{-# LANGUAGE bytesLength #-} withBytes :: Bytes -> (Ptr p -> IO a) -> IO a withBytes = withPtr@@ -119,32 +152,35 @@ case readWord8Array# m1 i s of (# s', e1 #) -> case readWord8Array# m2 i s' of (# s'', e2 #) ->- if booleanPrim (eqWord# e1 e2)+ if (W8# e1) == (W8# e2) then loop (i +# 1#) s''- else (# s', False #)+ else (# s'', False #)+ {-# INLINE loop #-} bytesCompare :: Bytes -> Bytes -> Ordering-bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ IO $ \s -> loop 0# s+bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ loop 0 where- !l1 = bytesLength b1- !l2 = bytesLength b2- !(I# len) = min l1 l2+ !l1 = bytesLength b1+ !l2 = bytesLength b2+ !len = min l1 l2 - loop i s1- | booleanPrim (i ==# len) =+ loop !i+ | i == len = if l1 == l2- then (# s1, EQ #)- else if l1 > l2 then (# s1, GT #)- else (# s1, LT #)- | otherwise =- case readWord8Array# m1 i s1 of- (# s2, e1 #) -> case readWord8Array# m2 i s2 of- (# s3, e2 #) ->- if booleanPrim (eqWord# e1 e2)- then loop (i +# 1#) s3- else if booleanPrim (ltWord# e1 e2) then (# s3, LT #)- else (# s3, GT #)+ 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@@ -154,7 +190,7 @@ chunkLoop idx | booleanPrim (len ==# idx) = [] | booleanPrim ((len -# idx) ># 63#) =- bytesLoop idx (idx +# 64#) (chunkLoop (idx +# 64#))+ bytesLoop idx 64# (chunkLoop (idx +# 64#)) | otherwise = bytesLoop idx (len -# idx) xs @@ -171,7 +207,7 @@ rChar :: Int# -> IO Char rChar idx = IO $ \s -> case readWord8Array# mba idx s of- (# s2, w #) -> (# s2, C# (chr# (word2Int# w)) #)+ (# s2, w #) -> (# s2, chr (integralUpsize (W8# w)) #) {- bytesShowHex :: Bytes -> String
Data/ByteArray/Encoding.hs view
@@ -5,7 +5,7 @@ -- Stability : experimental -- Portability : unknown ----- ByteArray base converting+-- Base conversions for 'ByteArray'. -- module Data.ByteArray.Encoding ( convertToBase@@ -21,13 +21,42 @@ import Data.Memory.Encoding.Base32 import Data.Memory.Encoding.Base64 --- | Different bases that can be used+-- $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@@ -35,7 +64,15 @@ | Base64OpenBSD -- ^ Base64 as used in OpenBSD password encoding (such as bcrypt) deriving (Show,Eq) --- | Convert a bytearray to the equivalent representation in a specific Base+-- | 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@@ -59,7 +96,20 @@ B.withByteArray b $ \bin -> f bout bin binLength --- | Try to Convert a bytearray from the equivalent representation in a specific Base+-- | 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"
Data/ByteArray/Mapping.hs view
@@ -8,6 +8,7 @@ module Data.ByteArray.Mapping ( toW64BE , toW64LE+ , fromW64BE , mapAsWord64 , mapAsWord128 ) where@@ -37,8 +38,12 @@ 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 +-- of equivalent size where each blocks has been mapped through @f@ -- -- no length checking is done. unsafe mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs@@ -59,7 +64,7 @@ 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 +-- of equivalent size where each blocks has been mapped through @f@ -- -- no length checking is done. unsafe mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs
Data/ByteArray/MemView.hs view
@@ -32,7 +32,7 @@ -- | Increase the memory view while reducing the size of the window ----- this is useful as an abtraction to represent the current offset+-- 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)
Data/ByteArray/Methods.hs view
@@ -5,6 +5,7 @@ -- Stability : stable -- Portability : Good --+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Data.ByteArray.Methods ( alloc@@ -25,6 +26,7 @@ , take , drop , span+ , reverse , convert , copyRet , copyAndFreeze@@ -47,14 +49,21 @@ import Foreign.Storable import Foreign.Ptr -import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred, last, any, all)+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@@ -70,6 +79,10 @@ 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 ())@@ -80,9 +93,11 @@ -- | Pack a list of bytes into a bytearray pack :: ByteArray a => [Word8] -> a-pack l = unsafeCreate (Prelude.length l) (fill 0 l)- where fill _ [] _ = return ()- fill i (x:xs) p = pokeByteOff p i x >> fill (i+1) xs p+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]@@ -156,8 +171,8 @@ | n <= 0 = empty | otherwise = unsafeCreate m $ \d -> withByteArray bs $ \s -> memCopy d s m where- m = min len n- len = length bs+ !m = min len n+ !len = length bs -- | drop the first @n@ byte of a bytearray drop :: ByteArray bs => Int -> bs -> bs@@ -176,9 +191,16 @@ | 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)@@ -187,7 +209,7 @@ loopCopy [] _ = return () loopCopy (x:xs) dst = do- withByteArray x $ \src -> memCopy dst src chunkLen+ copyByteArrayToPtr x dst loopCopy xs (dst `plusPtr` chunkLen) where !chunkLen = length x@@ -200,29 +222,30 @@ copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2 copy bs f = alloc (length bs) $ \d -> do- withByteArray bs $ \s -> memCopy d s (length bs)+ 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- withByteArray bs $ \s -> memCopy d s (length bs)+ 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 =- unsafeCreate (length bs) $ \d -> do- withByteArray bs $ \s -> memCopy d s (length bs)+ 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 = unsafeCreate n $ \ptr -> memSet ptr b n+ | otherwise = inlineUnsafeCreate n $ \ptr -> memSet ptr b n {-# NOINLINE replicate #-} -- | Create a bytearray of a specific size initialized to 0@@ -258,8 +281,8 @@ | l1 /= l2 = False | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memConstEqual p1 p2 l1 where- l1 = length b1- l2 = length b2+ !l1 = length b1+ !l2 = length b2 -- | Check if any element of a byte array satisfies a predicate any :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool@@ -280,4 +303,10 @@ -- | Convert a bytearray to another type of bytearray convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout-convert = flip copyAndFreeze (\_ -> return ())+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
Data/ByteArray/Pack.hs view
@@ -45,7 +45,7 @@ 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 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)@@ -55,7 +55,7 @@ | 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 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" #-}@@ -65,11 +65,11 @@ memSet ptr w size return $ PackerMore () (MemView (ptr `plusPtr` size) 0) --- | put a storable from the current position in the stream+-- | 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+-- | Put a Byte Array from the current position in the stream -- -- If the ByteArray is null, then do nothing putBytes :: ByteArrayAccess ba => ba -> Packer ()@@ -81,18 +81,20 @@ where neededLength = B.length bs --- | skip some bytes from the current position in the stream+-- | 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+-- | 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+-- | Fill up from the current position in the stream to the end ----- it is basically:+-- 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 #-}@@ -104,12 +106,19 @@ -- 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 -- will work--- > pack (fillList $ [1..] :: Word32) 1 -- will fail (not enough space)--- > pack (fillList $ [1..] :: Word32) 131 -- will fail (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
Data/ByteArray/Pack/Internal.hs view
@@ -14,7 +14,6 @@ , actionPackerWithRemain ) where -import Data.Word import Foreign.Ptr (Ptr) import Data.ByteArray.MemView import Data.Memory.Internal.Imports@@ -39,7 +38,7 @@ (<*>) = appendPacker instance Monad Packer where- return = returnPacker+ return = pure (>>=) = bindPacker fmapPacker :: (a -> b) -> Packer a -> Packer b
Data/ByteArray/Parse.hs view
@@ -12,8 +12,8 @@ -- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest" -- > ParseOK "est" ("xx", 116) --+{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Data.ByteArray.Parse ( Parser@@ -22,6 +22,7 @@ , parse , parseFeed -- * Parser methods+ , hasMore , byte , anyByte , bytes@@ -35,6 +36,7 @@ ) where import Control.Monad+import qualified Control.Monad.Fail as Fail import Foreign.Storable (Storable, peek, sizeOf) import Data.Word @@ -55,7 +57,7 @@ -- * success: the remaining unparsed data and the parser value data Result byteArray a = ParseFail String- | ParseMore (byteArray -> Result byteArray a)+ | ParseMore (Maybe byteArray -> Result byteArray a) | ParseOK byteArray a instance (Show ba, Show a) => Show (Result ba a) where@@ -63,31 +65,41 @@ 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 }+ { 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- fail errorMsg = Parser $ \buf err _ -> err buf ("failed: " ++ errorMsg)- return v = Parser $ \buf _ ok -> ok buf v- m >>= k = Parser $ \buf err ok ->+#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 "Parser.MonadPlus.mzero"+ 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 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 = return- (<*>) d e = d >>= \b -> e >>= \a -> return (b a) instance Alternative (Parser byteArray) where- empty = fail "Parser.Alternative.empty"+ empty = fail "Alternative.empty" (<|>) = mplus -- | Run a parser on an @initial byteArray.@@ -95,7 +107,10 @@ -- 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 byteArray -> Parser byteArray a -> byteArray -> m (Result byteArray a)+ => 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@@ -106,25 +121,47 @@ 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 ->- if B.null nextChunk- then err buf "EOL: need more data"- else ok (B.append buf 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 ->- if B.null nextChunk- then ok buf ()- else runParser getAll (B.append buf nextChunk) err ok+ 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 ->- if B.null nextChunk- then ok buf ()- else runParser getAll B.empty err ok+ 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@@ -142,7 +179,7 @@ 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")+ | otherwise -> err buf ("byte " ++ show w ++ " : failed : got " ++ show c1) -- | Parse a sequence of bytes from current position --
Data/ByteArray/ScrubbedBytes.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.ScrubbedBytes ( ScrubbedBytes ) where@@ -16,13 +17,27 @@ 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-import Data.Memory.PtrMethods (memCopy, memConstEqual)+#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.Memory.Internal.Scrubber (getScrubber) 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: --@@ -33,6 +48,7 @@ -- * A Eq instance that is constant time -- data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld)+ deriving (Typeable) instance Show ScrubbedBytes where show _ = "<scrubbed-bytes>"@@ -41,12 +57,25 @@ (==) = 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@@ -64,11 +93,31 @@ | otherwise = IO $ \s -> case newAlignedPinnedByteArray# sz 8# s of (# s1, mbarr #) ->- let !scrubber = getScrubber sz+ let !scrubber = getScrubber (byteArrayContents# (unsafeCoerce# mbarr)) !mba = ScrubbedBytes mbarr- in case mkWeak# mbarr () (scrubber (byteArrayContents# (unsafeCoerce# mbarr)) >> touchScrubbedBytes mba) s1 of+ 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@@ -124,23 +173,33 @@ l2 = sizeofScrubbedBytes b scrubbedBytesCompare :: ScrubbedBytes -> ScrubbedBytes -> Ordering-scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ IO $ \s -> loop 0# s+scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ loop 0 where- !l1 = sizeofScrubbedBytes b1- !l2 = sizeofScrubbedBytes b2- !(I# len) = min l1 l2+ !l1 = sizeofScrubbedBytes b1+ !l2 = sizeofScrubbedBytes b2+ !len = min l1 l2 - loop i s1- | booleanPrim (i ==# len) =+ loop !i+ | i == len = if l1 == l2- then (# s1, EQ #)- else if l1 > l2 then (# s1, GT #)- else (# s1, LT #)- | otherwise =- case readWord8Array# m1 i s1 of- (# s2, e1 #) -> case readWord8Array# m2 i s2 of- (# s3, e2 #) ->- if booleanPrim (eqWord# e1 e2)- then loop (i +# 1#) s3- else if booleanPrim (ltWord# e1 e2) then (# s3, LT #)- else (# s3, GT #)+ 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)
+ Data/ByteArray/Sized.hs view
@@ -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
Data/ByteArray/Types.hs view
@@ -6,6 +6,11 @@ -- Portability : Good -- {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Data.ByteArray.Types ( ByteArrayAccess(..) , ByteArray(..)@@ -15,32 +20,114 @@ import Data.Monoid #ifdef WITH_BYTESTRING_SUPPORT-import qualified Data.ByteString as B (length)-import qualified Data.ByteString.Internal as B+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- allocRet :: Int -> (Ptr p -> IO a) -> IO (a, ba)+ -- | 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 B.ByteString where- length = B.length- withByteArray b f = withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)- where (fptr, off, _) = B.toForeignPtr b+instance ByteArrayAccess Bytestring.ByteString where+ length = Bytestring.length+ withByteArray (Bytestring.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off) -instance ByteArray B.ByteString where+instance ByteArray Bytestring.ByteString where allocRet sz f = do- fptr <- B.mallocByteString sz+ fptr <- Bytestring.mallocByteString sz r <- withForeignPtr fptr (f . castPtr)- return (r, B.PS fptr 0 sz)+ 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
Data/Memory/Encoding/Base16.hs view
@@ -5,8 +5,11 @@ -- Stability : experimental -- Portability : unknown ----- Hexadecimal escaper+-- Low-level Base16 encoding and decoding. --+-- If you just want to encode or decode some bytes, you probably want to use+-- the "Data.ByteArray.Encoding" module.+-- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,10 +23,12 @@ import Data.Memory.Internal.Compat import Data.Word-import Data.Bits ((.|.))+import Basement.Bits+import Basement.IntegralConv import GHC.Prim import GHC.Types import GHC.Word+import GHC.Char (chr) import Control.Monad import Foreign.Storable import Foreign.Ptr (Ptr)@@ -39,7 +44,7 @@ doChunks ofs len | len < 4 = doUnique ofs len | otherwise = do- let !(W8# a, W8# b, W8# c, W8# d) = unsafeDoIO $ withPtr (read4 ofs)+ let !(a, b, c, d) = unsafeDoIO $ withPtr (read4 ofs) !(# w1, w2 #) = convertByte a !(# w3, w4 #) = convertByte b !(# w5, w6 #) = convertByte c@@ -51,7 +56,7 @@ doUnique ofs len | len == 0 = [] | otherwise =- let !(W8# b) = unsafeDoIO $ withPtr (byteIndex ofs)+ let !b = unsafeDoIO $ withPtr (byteIndex ofs) !(# w1, w2 #) = convertByte b in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1) @@ -60,8 +65,8 @@ liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p) (byteIndex (ofs+2) p) (byteIndex (ofs+3) p) - wToChar :: Word# -> Char- wToChar w = toEnum (I# (word2Int# w))+ wToChar :: Word8 -> Char+ wToChar w = chr (integralUpsize w) byteIndex :: Int -> Ptr Word8 -> IO Word8 byteIndex i p = peekByteOff p i@@ -78,19 +83,20 @@ where loop i | i == n = return () | otherwise = do- (W8# w) <- peekByteOff bin i- let !(# w1, w2 #) = convertByte w- pokeByteOff bout (i * 2) (W8# w1)- pokeByteOff bout (i * 2 + 1) (W8# w2)+ !w <- peekByteOff bin i+ let !(# !w1, !w2 #) = convertByte w+ pokeByteOff bout (i * 2) w1+ pokeByteOff bout (i * 2 + 1) w2 loop (i+1) -- | Convert a value Word# to two Word#s containing -- the hexadecimal representation of the Word#-convertByte :: Word# -> (# Word#, Word# #)-convertByte b = (# r tableHi b, r tableLo b #)+convertByte :: Word8 -> (# Word8, Word8 #)+convertByte bwrap = (# r tableHi b, r tableLo b #) where- r :: Addr# -> Word# -> Word#- r table index = indexWord8OffAddr# table (word2Int# index)+ !(W# b) = integralUpsize bwrap+ r :: Addr# -> Word# -> Word8+ r table index = W8# (indexWord8OffAddr# table (word2Int# index)) !tableLo = "0123456789abcdef0123456789abcdef\@@ -128,8 +134,11 @@ then return $ Just i else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2) - rLo (W8# index) = W8# (indexWord8OffAddr# tableLo (word2Int# index))- rHi (W8# index) = W8# (indexWord8OffAddr# tableHi (word2Int# index))+ rLo, rHi :: Word8 -> Word8+ rLo index = W8# (indexWord8OffAddr# tableLo (word2Int# widx))+ where !(W# widx) = integralUpsize index+ rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx))+ where !(W# widx) = integralUpsize index !tableLo = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\@@ -165,4 +174,3 @@ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#-
Data/Memory/Encoding/Base32.hs view
@@ -5,8 +5,11 @@ -- Stability : experimental -- Portability : unknown ----- Base32+-- Low-level Base32 encoding and decoding. --+-- If you just want to encode or decode some bytes, you probably want to use+-- the "Data.ByteArray.Encoding" module.+-- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE OverloadedStrings #-}@@ -19,9 +22,9 @@ ) where import Data.Memory.Internal.Compat-import Data.Memory.Internal.CompatPrim import Data.Word-import Data.Bits ((.|.))+import Basement.Bits+import Basement.IntegralConv import GHC.Prim import GHC.Word import Control.Monad@@ -58,7 +61,7 @@ -> Int -- index output -> IO () loop i di- | i > len = return ()+ | i >= len = return () | otherwise = do i1 <- peekByteOff src i i2 <- peekOrZero (i + 1)@@ -81,36 +84,38 @@ toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)-toBase32Per5Bytes (W8# i1, W8# i2, W8# i3, W8# i4, W8# i5) =+toBase32Per5Bytes (!i1, !i2, !i3, !i4, !i5) = (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8) where -- 1111 1000 >> 3- !o1 = (uncheckedShiftRL# (and# i1 0xF8##) 3#)+ !o1 = (i1 .&. 0xF8) .>>. 3 -- 0000 0111 << 2 | 1100 0000 >> 6- !o2 = or# (uncheckedShiftL# (and# i1 0x07##) 2#) (uncheckedShiftRL# (and# i2 0xC0##) 6#)+ !o2 = ((i1 .&. 0x07) .<<. 2) .|. ((i2 .&. 0xC0) .>>. 6) -- 0011 1110 >> 1- !o3 = (uncheckedShiftRL# (and# i2 0x3E##) 1#)+ !o3 = ((i2 .&. 0x3E) .>>. 1) -- 0000 0001 << 4 | 1111 0000 >> 4- !o4 = or# (uncheckedShiftL# (and# i2 0x01##) 4#) (uncheckedShiftRL# (and# i3 0xF0##) 4#)+ !o4 = ((i2 .&. 0x01) .<<. 4) .|. ((i3 .&. 0xF0) .>>. 4) -- 0000 1111 << 1 | 1000 0000 >> 7- !o5 = or# (uncheckedShiftL# (and# i3 0x0F##) 1#) (uncheckedShiftRL# (and# i4 0x80##) 7#)+ !o5 = ( (i3 .&. 0x0F) .<<. 1) .|. ((i4 .&. 0x80) .>>. 7) -- 0111 1100 >> 2- !o6 = (uncheckedShiftRL# (and# i4 0x7C##) 2#)+ !o6 = (i4 .&. 0x7C) .>>. 2 -- 0000 0011 << 3 | 1110 0000 >> 5- !o7 = or# (uncheckedShiftL# (and# i4 0x03##) 3#) (uncheckedShiftRL# (and# i5 0xE0##) 5#)+ !o7 = ((i4 .&. 0x03) .<<. 3) .|. ((i5 .&. 0xE0) .>>. 5) -- 0001 1111- !o8 = ((and# i5 0x1F##))+ !o8 = i5 .&. 0x1F !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# - index :: Word# -> Word8- index idx = W8# (indexWord8OffAddr# set (word2Int# idx))+ index :: Word8 -> Word8+ index idx = W8# (indexWord8OffAddr# set (word2Int# widx))+ where !(W# widx) = integralUpsize idx -- | Get the length needed for the destination buffer for a base32 decoding. -- -- if the length is not a multiple of 8, Nothing is returned unBase32Length :: Ptr Word8 -> Int -> IO (Maybe Int) unBase32Length src len+ | len < 1 = return $ Just 0 | (len `mod` 8) /= 0 = return Nothing | otherwise = do last1Byte <- peekByteOff src (len - 1)@@ -230,9 +235,8 @@ in Right (o1, o2, o3, o4, o5) where rset :: Word8 -> Word8- rset (W8# w)- | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))- | otherwise = 0xff+ rset w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))+ where !(W# widx) = integralUpsize w !rsetTable = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\@@ -250,4 +254,3 @@ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"#-
Data/Memory/Encoding/Base64.hs view
@@ -5,8 +5,11 @@ -- Stability : experimental -- Portability : unknown ----- Base64+-- Low-level Base64 encoding and decoding. --+-- If you just want to encode or decode some bytes, you probably want to use+-- the "Data.ByteArray.Encoding" module.+-- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE OverloadedStrings #-}@@ -23,11 +26,10 @@ , fromBase64OpenBSD ) where -import Control.Monad import Data.Memory.Internal.Compat-import Data.Memory.Internal.CompatPrim import Data.Memory.Internal.Imports-import Data.Bits ((.|.))+import Basement.Bits+import Basement.IntegralConv (integralUpsize) import GHC.Prim import GHC.Word import Foreign.Storable@@ -89,21 +91,23 @@ loop (i+3) (di+4) convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8)-convert3 table (W8# a) (W8# b) (W8# c) =- let !w = narrow8Word# (uncheckedShiftRL# a 2#)- !x = or# (and# (uncheckedShiftL# a 4#) 0x30##) (uncheckedShiftRL# b 4#)- !y = or# (and# (uncheckedShiftL# b 2#) 0x3c##) (uncheckedShiftRL# c 6#)- !z = and# c 0x3f##+convert3 table !a !b !c =+ let !w = a .>>. 2+ !x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4)+ !y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6)+ !z = c .&. 0x3f in (index w, index x, index y, index z) where- index :: Word# -> Word8- index idx = W8# (indexWord8OffAddr# table (word2Int# idx))+ index :: Word8 -> Word8+ index !idxb = W8# (indexWord8OffAddr# table (word2Int# idx))+ where !(W# idx) = integralUpsize idxb -- | Get the length needed for the destination buffer for a base64 decoding. -- -- if the length is not a multiple of 4, Nothing is returned unBase64Length :: Ptr Word8 -> Int -> IO (Maybe Int) unBase64Length src len+ | len < 1 = return $ Just 0 | (len `mod` 4) /= 0 = return Nothing | otherwise = do last1Byte <- peekByteOff src (len - 1)@@ -207,10 +211,9 @@ in Right (x,y,z) rsetURL :: Word8 -> Word8-rsetURL (W8# w)- | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))- | otherwise = 0xff- where !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+rsetURL !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))+ where !(W# widx) = integralUpsize w+ !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\ \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\@@ -228,10 +231,9 @@ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# rsetOpenBSD :: Word8 -> Word8-rsetOpenBSD (W8# w)- | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))- | otherwise = 0xff- where !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+rsetOpenBSD !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))+ where !(W# widx) = integralUpsize w+ !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\ \\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\xff\xff\xff\xff\xff\xff\@@ -305,9 +307,8 @@ in Right (x,y,z) rset :: Word8 -> Word8- rset (W8# w)- | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))- | otherwise = 0xff+ rset !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))+ where !(W# widx) = integralUpsize w !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
Data/Memory/Hash/FNV.hs view
@@ -24,9 +24,9 @@ , fnv1a_64 ) where +import Basement.Bits+import Basement.IntegralConv import Data.Memory.Internal.Compat ()-import Data.Memory.Internal.CompatPrim-import Data.Memory.Internal.CompatPrim64 import Data.Memory.Internal.Imports import GHC.Word import GHC.Prim hiding (Word64#, Int64#)@@ -41,66 +41,66 @@ newtype FnvHash64 = FnvHash64 Word64 deriving (Show,Eq,Ord,NFData) +fnv1_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32+fnv1_32_Mix8 !w (FnvHash32 acc) = FnvHash32 ((0x01000193 * acc) .^. integralUpsize w)+{-# INLINE fnv1_32_Mix8 #-}++fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32+fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * (acc .^. integralUpsize w))+{-# INLINE fnv1a_32_Mix8 #-}++fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64+fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 ((0x100000001b3 * acc) .^. integralUpsize w)+{-# INLINE fnv1_64_Mix8 #-}++fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64+fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * (acc .^. integralUpsize w))+{-# INLINE fnv1a_64_Mix8 #-}+ -- | compute FNV1 (32 bit variant) of a raw piece of memory fnv1 :: Ptr Word8 -> Int -> IO FnvHash32-fnv1 (Ptr addr) (I# n) = IO $ \s -> loop 0x811c9dc5## 0# s+fnv1 (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 where - loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash32 #)- loop !acc i s- | booleanPrim (i ==# n) = (# s, FnvHash32 $ W32# (narrow32Word# acc) #)- | otherwise =- case readWord8OffAddr# addr i s of- (# s2, v #) ->- let !nacc = (0x01000193## `timesWord#` acc) `xor#` v- in loop nacc (i +# 1#) s2+ loop :: FnvHash32 -> Int -> IO FnvHash32+ loop !acc !i+ | i == n = pure $ acc+ | otherwise = do+ v <- read8 addr i+ loop (fnv1_32_Mix8 v acc) (i + 1) -- | compute FNV1a (32 bit variant) of a raw piece of memory fnv1a :: Ptr Word8 -> Int -> IO FnvHash32-fnv1a (Ptr addr) (I# n) = IO $ \s -> loop 0x811c9dc5## 0# s+fnv1a (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 where - loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash32 #)- loop !acc i s- | booleanPrim (i ==# n) = (# s, FnvHash32 $ W32# (narrow32Word# acc) #)- | otherwise =- case readWord8OffAddr# addr i s of- (# s2, v #) ->- let !nacc = 0x01000193## `timesWord#` (acc `xor#` v)- in loop nacc (i +# 1#) s2+ loop :: FnvHash32 -> Int -> IO FnvHash32+ loop !acc !i+ | i == n = pure $ acc+ | otherwise = do+ v <- read8 addr i+ loop (fnv1a_32_Mix8 v acc) (i + 1) -- | compute FNV1 (64 bit variant) of a raw piece of memory fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64-fnv1_64 (Ptr addr) (I# n) = IO $ \s -> loop fnv64Const 0# s+fnv1_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 where - loop :: Word64# -> Int# -> State# s -> (# State# s, FnvHash64 #)- loop !acc i s- | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #)- | otherwise =- case readWord8OffAddr# addr i s of- (# s2, v #) ->- let !nacc = (fnv64Prime `timesWord64#` acc) `xor64#` (wordToWord64# v)- in loop nacc (i +# 1#) s2-- fnv64Const :: Word64#- !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325##-- fnv64Prime :: Word64#- !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3##+ loop :: FnvHash64 -> Int -> IO FnvHash64+ loop !acc !i+ | i == n = pure $ acc+ | otherwise = do+ v <- read8 addr i+ loop (fnv1_64_Mix8 v acc) (i + 1) -- | compute FNV1a (64 bit variant) of a raw piece of memory fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64-fnv1a_64 (Ptr addr) (I# n) = IO $ \s -> loop fnv64Const 0# s+fnv1a_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 where - loop :: Word64# -> Int# -> State# s -> (# State# s, FnvHash64 #)- loop !acc i s- | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #)- | otherwise =- case readWord8OffAddr# addr i s of- (# s2, v #) ->- let !nacc = fnv64Prime `timesWord64#` (acc `xor64#` wordToWord64# v)- in loop nacc (i +# 1#) s2-- fnv64Const :: Word64#- !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325##+ loop :: FnvHash64 -> Int -> IO FnvHash64+ loop !acc !i+ | i == n = pure $ acc+ | otherwise = do+ v <- read8 addr i+ loop (fnv1a_64_Mix8 v acc) (i + 1) - fnv64Prime :: Word64#- !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3##+read8 :: Addr# -> Int -> IO Word8+read8 addr (I# i) = IO $ \s -> case readWord8OffAddr# addr i s of+ (# s2, e #) -> (# s2, W8# e #)
Data/Memory/Hash/SipHash.hs view
@@ -9,6 +9,7 @@ -- reference: <http://131002.net/siphash/siphash.pdf> -- {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-} module Data.Memory.Hash.SipHash ( SipKey(..) , SipHash(..)@@ -20,6 +21,7 @@ import Data.Memory.Internal.Compat import Data.Word import Data.Bits+import Data.Typeable (Typeable) import Control.Monad import Foreign.Ptr import Foreign.Storable@@ -29,7 +31,7 @@ -- | Siphash tag value newtype SipHash = SipHash Word64- deriving (Show,Eq,Ord)+ deriving (Show,Eq,Ord,Typeable) data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
Data/Memory/Internal/CompatPrim.hs view
@@ -14,13 +14,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} module Data.Memory.Internal.CompatPrim ( be32Prim , le32Prim , byteswap32Prim , booleanPrim- , eitherDivideBy8# ) where import GHC.Prim@@ -69,21 +67,4 @@ booleanPrim :: Bool -> Bool booleanPrim b = b #endif---- | Apply or or another function if 8 divides the number of bytes-eitherDivideBy8# :: Int# -- ^ number of bytes- -> (Int# -> a) -- ^ if it divided by 8, the argument is the number of 8 bytes words- -> (Int# -> a) -- ^ if it doesn't, just the number of bytes- -> a-#if __GLASGOW_HASKELL__ >= 740-eitherDivideBy8# v f8 f1 =- let !(# q, r #) = quotRemInt v 8#- in if booleanPrim (r ==# 0)- then f8 q- else f1 v-#else-eitherDivideBy8# v f8 f1 =- if booleanPrim ((remInt# v 8#) ==# 0#)- then f8 (quotInt# v 8#)- else f1 v-#endif+{-# INLINE booleanPrim #-}
Data/Memory/Internal/CompatPrim64.hs view
@@ -63,6 +63,7 @@ type Word64# = Word# type Int64# = Int# +#if __GLASGOW_HASKELL__ < 904 eqWord64# :: Word64# -> Word64# -> OutBool eqWord64# = eqWord# @@ -143,6 +144,7 @@ timesWord64# :: Word64# -> Word64# -> Word64# timesWord64# = timesWord#+#endif w64# :: Word# -> Word# -> Word# -> Word64# w64# w _ _ = w
Data/Memory/Internal/Imports.hs view
@@ -12,6 +12,6 @@ import Data.Word as X import Control.Applicative as X-import Control.Monad as X (forM, forM_, void)+import Control.Monad as X (forM, forM_, void, when) import Control.Arrow as X (first, second) import Data.Memory.Internal.DeepSeq as X
− Data/Memory/Internal/Scrubber.hs
@@ -1,72 +0,0 @@--- |--- Module : Data.Memory.Internal.Scrubber--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : stable--- Portability : Compat----{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-#include "MachDeps.h"-module Data.Memory.Internal.Scrubber- ( getScrubber- ) where--import GHC.Prim-import GHC.IO-import Data.Memory.Internal.CompatPrim (booleanPrim)--getScrubber :: Int# -> (Addr# -> IO ())-getScrubber sz - | booleanPrim (sz ==# 4#) = scrub4- | booleanPrim (sz ==# 8#) = scrub8- | booleanPrim (sz ==# 16#) = scrub16- | booleanPrim (sz ==# 32#) = scrub32- | otherwise = scrubBytes sz- where- scrub4 a = IO $ \s -> (# writeWord32OffAddr# a 0# 0## s, () #)-#if WORD_SIZE_IN_BITS == 64- scrub8 a = IO $ \s -> (# writeWord64OffAddr# a 0# 0## s, () #)- scrub16 a = IO $ \s1 ->- let !s2 = writeWord64OffAddr# a 0# 0## s1- !s3 = writeWord64OffAddr# a 1# 0## s2- in (# s3, () #)- scrub32 a = IO $ \s1 ->- let !s2 = writeWord64OffAddr# a 0# 0## s1- !s3 = writeWord64OffAddr# a 1# 0## s2- !s4 = writeWord64OffAddr# a 2# 0## s3- !s5 = writeWord64OffAddr# a 3# 0## s4- in (# s5, () #)-#else- scrub8 a = IO $ \s1 ->- let !s2 = writeWord32OffAddr# a 0# 0## s1- !s3 = writeWord32OffAddr# a 1# 0## s2- in (# s3, () #)- scrub16 a = IO $ \s1 ->- let !s2 = writeWord32OffAddr# a 0# 0## s1- !s3 = writeWord32OffAddr# a 1# 0## s2- !s4 = writeWord32OffAddr# a 2# 0## s3- !s5 = writeWord32OffAddr# a 3# 0## s4- in (# s5, () #)- scrub32 a = IO $ \s1 ->- let !s2 = writeWord32OffAddr# a 0# 0## s1- !s3 = writeWord32OffAddr# a 1# 0## s2- !s4 = writeWord32OffAddr# a 2# 0## s3- !s5 = writeWord32OffAddr# a 3# 0## s4- !s6 = writeWord32OffAddr# a 4# 0## s5- !s7 = writeWord32OffAddr# a 5# 0## s6- !s8 = writeWord32OffAddr# a 6# 0## s7- !s9 = writeWord32OffAddr# a 7# 0## s8- in (# s9, () #)-#endif--scrubBytes :: Int# -> Addr# -> IO ()-scrubBytes sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)- where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld- loop n a s- | booleanPrim (n ==# 0#) = s- | otherwise =- case writeWord8OffAddr# a 0# 0## s of- s' -> loop (n -# 1#) (plusAddr# a 1#) s'
Data/Memory/PtrMethods.hs view
@@ -17,6 +17,7 @@ , memXorWith , memCopy , memSet+ , memReverse , memEqual , memConstEqual , memCompare@@ -24,7 +25,7 @@ import Data.Memory.Internal.Imports import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Storable (peek, poke, pokeByteOff, peekByteOff)+import Foreign.Storable (peek, poke, peekByteOff) import Foreign.C.Types import Foreign.Marshal.Alloc (allocaBytesAligned) import Data.Bits ((.|.), xor)@@ -48,21 +49,35 @@ -- -- d = replicate (sizeof s) v `xor` s memXorWith :: Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO ()-memXorWith d v s n = loop 0+memXorWith destination !v source bytes+ | destination == source = loopInplace source bytes+ | otherwise = loop destination source bytes where- loop i- | i == n = return ()- | otherwise = do- (xor v <$> peekByteOff s i) >>= pokeByteOff d i- loop (i+1)+ loop !d !s n = when (n > 0) $ do+ peek s >>= poke d . xor v+ loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1) + loopInplace !s n = when (n > 0) $ do+ peek s >>= poke s . xor v+ loopInplace (s `plusPtr` 1) (n-1)+ -- | Copy a set number of bytes from @src to @dst memCopy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () memCopy dst src n = c_memcpy dst src (fromIntegral n)+{-# INLINE memCopy #-} -- | Set @n number of bytes to the same value @v memSet :: Ptr Word8 -> Word8 -> Int -> IO ()-memSet start v n = c_memset start (fromIntegral v) (fromIntegral n) >>= \_ -> return ()+memSet start v n = c_memset start v (fromIntegral n) >>= \_ -> return ()+{-# INLINE memSet #-}++-- | Reverse a set number of bytes from @src@ to @dst@. Memory+-- locations should not overlap.+memReverse :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memReverse d s n+ | n > 0 = do peekByteOff s (n - 1) >>= poke d+ memReverse (d `plusPtr` 1) s (n - 1)+ | otherwise = return () -- | Check if two piece of memory are equals memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2015-2018 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2017-2018 Nicolas Di Prima <nicolas@primetype.co.uk> All rights reserved.
README.md view
@@ -37,22 +37,4 @@ Support ------- -Memory supports the following platform:--* Windows >= 7-* OSX >= 10.8-* Linux--On the following architectures:--* x86-64-* i386--On the following haskell versions:--* GHC 7.0.x-* GHC 7.4.x-* GHC 7.6.x-* GHC 7.8.x-* GHC 7.10.x-+See [Haskell packages guidelines](https://github.com/vincenthz/haskell-pkg-guidelines/blob/master/README.md#support)
memory.cabal view
@@ -1,5 +1,5 @@ Name: memory-Version: 0.10+version: 0.18.0 Synopsis: memory and related abstraction stuff Description: Chunk of memory, polymorphic byte array management and manipulation@@ -13,17 +13,19 @@ * Aliasing with endianness support. . * Encoding : Base16, Base32, Base64.+ .+ * Hashing : FNV, SipHash License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez <vincent@snarc.org> Author: Vincent Hanquez <vincent@snarc.org>-Maintainer: vincent@snarc.org+Maintainer: vincent@snarc.org, Nicolas Di Prima <nicolas@primetype.co.uk> Category: memory Stability: experimental Build-Type: Simple Homepage: https://github.com/vincenthz/hs-memory Bug-Reports: https://github.com/vincenthz/hs-memory/issues-Cabal-Version: >=1.10+cabal-version: 1.18 extra-doc-files: README.md CHANGELOG.md source-repository head@@ -58,7 +60,6 @@ Data.Memory.Internal.CompatPrim64 Data.Memory.Internal.DeepSeq Data.Memory.Internal.Imports- Data.Memory.Internal.Scrubber Data.Memory.Hash.SipHash Data.Memory.Hash.FNV Data.ByteArray.Pack.Internal@@ -68,7 +69,10 @@ Data.ByteArray.Methods Data.ByteArray.MemView Data.ByteArray.View- Build-depends: base >= 4 && < 5+ if impl(ghc < 8.8)+ buildable: False+ else+ build-depends: base , ghc-prim -- FIXME armel or mispel is also little endian. -- might be a good idea to also add a runtime autodetect mode.@@ -86,8 +90,12 @@ Build-depends: bytestring if flag(support_deepseq) CPP-options: -DWITH_DEEPSEQ_SUPPORT- Build-depends: deepseq+ Build-depends: deepseq >= 1.1 + CPP-options: -DWITH_BASEMENT_SUPPORT+ Build-depends: basement >= 0.0.7+ exposed-modules: Data.ByteArray.Sized+ ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 @@ -98,10 +106,25 @@ Other-modules: Imports SipHash Utils- Build-Depends: base >= 3 && < 5- , tasty- , tasty-quickcheck- , tasty-hunit+ if impl(ghc < 8.8)+ buildable: False+ else+ build-depends: base+ Build-Depends: bytestring , memory+ , basement >= 0.0.7+ , foundation ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded default-language: Haskell2010+ CPP-options: -DWITH_BASEMENT_SUPPORT++-- Test-Suite test-examples+-- default-language: Haskell2010+-- type: exitcode-stdio-1.0+-- hs-source-dirs: tests+-- ghc-options: -threaded+-- Main-is: DocTests.hs+-- Build-Depends: base >= 3 && < 5+-- , memory+-- , bytestring+-- , doctest
tests/Imports.hs view
@@ -2,11 +2,10 @@ ( module X ) where -import Control.Applicative as X-import Control.Monad as X-import Data.Foldable as X (foldl')-import Data.Monoid as X+import Prelude as X (zip)+import Control.Monad as X (replicateM)+import Data.List as X (concatMap) -import Test.Tasty as X-import Test.Tasty.HUnit as X-import Test.Tasty.QuickCheck as X hiding (vector)+import Foundation as X+import Foundation.Collection as X (nonEmpty_)+import Foundation.Check as X
tests/SipHash.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module SipHash (tests) where @@ -268,9 +269,9 @@ ) ] -katTests witnessID v = map makeTest $ numberedList v- where makeTest (i, (key,msg,tag)) = testCase ("kat " ++ show i) $ tag @=? sipHash key (witnessID $ B.pack $ unS msg)+katTests witnessID v = makeTest <$> numberedList v+ where makeTest (i, (key,msg,tag)) = Property ("kat " <> show i) $ tag === sipHash key (witnessID $ B.pack $ unS msg) tests witnessID =- [ testGroup "KAT" $ katTests witnessID vectors+ [ Group "KAT" $ katTests witnessID vectors ]
tests/Tests.hs view
@@ -1,10 +1,17 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} module Main where import Imports+import Foundation.Check.Main import Utils+import Data.Char (chr) import Data.Word+import qualified Data.ByteString as BS import Data.ByteArray (Bytes, ScrubbedBytes, ByteArray) import qualified Data.ByteArray as B import qualified Data.ByteArray.Encoding as B@@ -12,29 +19,51 @@ import qualified SipHash +#ifdef WITH_BASEMENT_SUPPORT+import Basement.Block (Block)+import Basement.UArray (UArray)+#endif++newtype Positive = Positive Word+ deriving (Show, Eq, Ord)+instance Arbitrary Positive where+ arbitrary = Positive <$> between (0, 255)+ data Backend = BackendByte | BackendScrubbedBytes+#ifdef WITH_BASEMENT_SUPPORT+#if MIN_VERSION_basement(0,0,5)+ | BackendBlock+#endif+ | BackendUArray+#endif deriving (Show,Eq,Bounded,Enum) -allBackends :: [Backend]-allBackends = enumFrom BackendByte+allBackends :: NonEmpty [Backend]+allBackends = nonEmpty_ $ enumFrom BackendByte data ArbitraryBS = forall a . ByteArray a => ArbitraryBS a -arbitraryBS :: Int -> Gen ArbitraryBS+arbitraryBS :: Word -> Gen ArbitraryBS arbitraryBS n = do backend <- elements allBackends case backend of- BackendByte -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM n arbitrary) :: Gen Bytes)- BackendScrubbedBytes -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM n arbitrary) :: Gen ScrubbedBytes)+ BackendByte -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen Bytes)+ BackendScrubbedBytes -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen ScrubbedBytes)+#ifdef WITH_BASEMENT_SUPPORT+#if MIN_VERSION_basement(0,0,5)+ BackendBlock -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (Block Word8))+#endif+ BackendUArray -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (UArray Word8))+#endif -arbitraryBSof :: Int -> Int -> Gen ArbitraryBS-arbitraryBSof minBytes maxBytes = choose (minBytes, maxBytes) >>= arbitraryBS+arbitraryBSof :: Word -> Word -> Gen ArbitraryBS+arbitraryBSof minBytes maxBytes = between (minBytes, maxBytes) >>= arbitraryBS newtype SmallList a = SmallList [a] deriving (Show,Eq) instance Arbitrary a => Arbitrary (SmallList a) where- arbitrary = choose (0,8) >>= \n -> SmallList `fmap` replicateM n arbitrary+ arbitrary = between (0,8) >>= \n -> SmallList `fmap` replicateM (fromIntegral n) arbitrary instance Arbitrary ArbitraryBS where arbitrary = arbitraryBSof 0 259@@ -43,21 +72,39 @@ deriving (Show,Eq) instance Arbitrary Words8 where- arbitrary = choose (0, 259) >>= \n -> Words8 <$> replicateM n arbitrary+ arbitrary = between (0, 259) >>= \n -> Words8 <$> replicateM (fromIntegral n) arbitrary -testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, ByteArray ba) => (ba -> ba) -> [TestTree]) -> TestTree+testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [Test]) -> Test testGroupBackends x l =- testGroup x- [ testGroup "Bytes" (l withBytesWitness)- , testGroup "ScrubbedBytes" (l withScrubbedBytesWitness)+ Group x+ [ Group "Bytes" (l withBytesWitness)+ , Group "ScrubbedBytes" (l withScrubbedBytesWitness)+#ifdef WITH_BASEMENT_SUPPORT+ , Group "Block" (l withBlockWitness)+ , Group "UArray" (l withUArrayWitness)+#endif ] +testShowProperty :: IsProperty a+ => String+ -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a)+ -> Test+testShowProperty x p =+ Group x+ [ Property "Bytes" (p withBytesWitness showLikeString)+ , Property "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB)+ ]+ where+ showLikeString l = show $ (chr . fromIntegral) <$> l+ showLikeEmptySB _ = show (withScrubbedBytesWitness B.empty)+ base64Kats = [ ("pleasure.", "cGxlYXN1cmUu") , ("leasure.", "bGVhc3VyZS4=") , ("easure.", "ZWFzdXJlLg==") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4=")+ , ("", "") ] base64URLKats =@@ -89,101 +136,157 @@ ] encodingTests witnessID =- [ testGroup "BASE64"- [ testGroup "encode-KAT" encodeKats64- , testGroup "decode-KAT" decodeKats64+ [ Group "BASE64"+ [ Group "encode-KAT" encodeKats64+ , Group "decode-KAT" decodeKats64 ]- , testGroup "BASE64URL"- [ testGroup "encode-KAT" encodeKats64URLUnpadded- , testGroup "decode-KAT" decodeKats64URLUnpadded+ , Group "BASE64URL"+ [ Group "encode-KAT" encodeKats64URLUnpadded+ , Group "decode-KAT" decodeKats64URLUnpadded ]- , testGroup "BASE32"- [ testGroup "encode-KAT" encodeKats32- , testGroup "decode-KAT" decodeKats32+ , Group "BASE32"+ [ Group "encode-KAT" encodeKats32+ , Group "decode-KAT" decodeKats32 ]- , testGroup "BASE16"- [ testGroup "encode-KAT" encodeKats16- , testGroup "decode-KAT" decodeKats16+ , Group "BASE16"+ [ Group "encode-KAT" encodeKats16+ , Group "decode-KAT" decodeKats16 ] ] where- encodeKats64 = map (toTest B.Base64) $ zip [1..] base64Kats- decodeKats64 = map (toBackTest B.Base64) $ zip [1..] base64Kats- encodeKats32 = map (toTest B.Base32) $ zip [1..] base32Kats- decodeKats32 = map (toBackTest B.Base32) $ zip [1..] base32Kats- encodeKats16 = map (toTest B.Base16) $ zip [1..] base16Kats- decodeKats16 = map (toBackTest B.Base16) $ zip [1..] base16Kats- encodeKats64URLUnpadded = map (toTest B.Base64URLUnpadded) $ zip [1..] base64URLKats- decodeKats64URLUnpadded = map (toBackTest B.Base64URLUnpadded) $ zip [1..] base64URLKats+ encodeKats64 = fmap (toTest B.Base64) $ zip [1..] base64Kats+ decodeKats64 = fmap (toBackTest B.Base64) $ zip [1..] base64Kats+ encodeKats32 = fmap (toTest B.Base32) $ zip [1..] base32Kats+ decodeKats32 = fmap (toBackTest B.Base32) $ zip [1..] base32Kats+ encodeKats16 = fmap (toTest B.Base16) $ zip [1..] base16Kats+ decodeKats16 = fmap (toBackTest B.Base16) $ zip [1..] base16Kats+ encodeKats64URLUnpadded = fmap (toTest B.Base64URLUnpadded) $ zip [1..] base64URLKats+ decodeKats64URLUnpadded = fmap (toBackTest B.Base64URLUnpadded) $ zip [1..] base64URLKats - toTest :: B.Base -> (Int, (String, String)) -> TestTree- toTest base (i, (inp, out)) = testCase (show i) $+ toTest :: B.Base -> (Int, (LString, LString)) -> Test+ toTest base (i, (inp, out)) = Property (show i) $ let inpbs = witnessID $ B.convertToBase base $ witnessID $ B.pack $ unS inp outbs = witnessID $ B.pack $ unS out- in outbs @=? inpbs- toBackTest :: B.Base -> (Int, (String, String)) -> TestTree- toBackTest base (i, (inp, out)) = testCase (show i) $+ in outbs === inpbs+ toBackTest :: B.Base -> (Int, (LString, LString)) -> Test+ toBackTest base (i, (inp, out)) = Property (show i) $ let inpbs = witnessID $ B.pack $ unS inp outbs = B.convertFromBase base $ witnessID $ B.pack $ unS out- in Right inpbs @=? outbs+ in Right inpbs === outbs +-- check not to touch internal null pointer of the empty ByteString+bsNullEncodingTest =+ Group "BS-null"+ [ Group "BASE64"+ [ Property "encode-KAT" $ toTest B.Base64+ , Property "decode-KAT" $ toBackTest B.Base64+ ]+ , Group "BASE32"+ [ Property "encode-KAT" $ toTest B.Base32+ , Property "decode-KAT" $ toBackTest B.Base32+ ]+ , Group "BASE16"+ [ Property "encode-KAT" $ toTest B.Base16+ , Property "decode-KAT" $ toBackTest B.Base16+ ]+ ]+ where+ toTest base =+ B.convertToBase base BS.empty === BS.empty+ toBackTest base =+ B.convertFromBase base BS.empty === Right BS.empty+ parsingTests witnessID =- [ testCase "parse" $+ [ CheckPlan "parse" $ let input = witnessID $ B.pack $ unS "xx abctest" abc = witnessID $ B.pack $ unS "abc" est = witnessID $ B.pack $ unS "est" result = Parse.parse ((,,) <$> Parse.take 2 <*> Parse.byte 0x20 <*> (Parse.bytes abc *> Parse.anyByte)) input in case result of- Parse.ParseOK remaining (_,_,_) -> est @=? remaining- _ -> assertFailure ""+ Parse.ParseOK remaining (_,_,_) -> validate "remaining" $ est === remaining+ _ -> validate "unexpected result" False ] -main = defaultMain $ testGroup "memory"- [ localOption (QuickCheckTests 5000) $ testGroupBackends "basic" basicProperties+main = defaultMain $ Group "memory"+ [ testGroupBackends "basic" basicProperties+ , bsNullEncodingTest , testGroupBackends "encoding" encodingTests , testGroupBackends "parsing" parsingTests , testGroupBackends "hashing" $ \witnessID ->- [ testGroup "SipHash" $ SipHash.tests witnessID+ [ Group "SipHash" $ SipHash.tests witnessID ]+ , testShowProperty "showing" $ \witnessID expectedShow (Words8 l) ->+ (show . witnessID . B.pack $ l) == expectedShow l+#ifdef WITH_BASEMENT_SUPPORT+ , testFoundationTypes+#endif ] where basicProperties witnessID =- [ testProperty "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l)- , testProperty "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b- , testProperty "add-empty-eq" $ \(Words8 l) ->+ [ Property "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l)+ , Property "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b+ , Property "add-empty-eq" $ \(Words8 l) -> let b = witnessID $ B.pack l in B.append b B.empty == b- , testProperty "zero" $ \(Positive n) ->- let expected = witnessID $ B.pack $ replicate n 0- in expected == B.zero n- , testProperty "Ord" $ \(Words8 l1) (Words8 l2) ->+ , Property "zero" $ \(Positive n) ->+ let expected = witnessID $ B.pack $ replicate (fromIntegral n) 0+ in expected == B.zero (fromIntegral n)+ , Property "Ord" $ \(Words8 l1) (Words8 l2) -> compare l1 l2 == compare (witnessID $ B.pack l1) (B.pack l2)- , testProperty "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) ->+ , Property "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) -> mappend l1 l2 == (B.unpack $ mappend (witnessID $ B.pack l1) (B.pack l2))- , testProperty "Monoid(mconcat)" $ \(SmallList l) ->- mconcat (map unWords8 l) == (B.unpack $ mconcat $ map (witnessID . B.pack . unWords8) l)- , testProperty "append (append a b) c == append a (append b c)" $ \(Words8 la) (Words8 lb) (Words8 lc) ->+ , Property "Monoid(mconcat)" $ \(SmallList l) ->+ mconcat (fmap unWords8 l) == (B.unpack $ mconcat $ fmap (witnessID . B.pack . unWords8) l)+ , Property "append (append a b) c == append a (append b c)" $ \(Words8 la) (Words8 lb) (Words8 lc) -> let a = witnessID $ B.pack la b = witnessID $ B.pack lb c = witnessID $ B.pack lc in B.append (B.append a b) c == B.append a (B.append b c)- , testProperty "concat l" $ \(SmallList l) ->- let chunks = map (witnessID . B.pack . unWords8) l+ , Property "concat l" $ \(SmallList l) ->+ let chunks = fmap (witnessID . B.pack . unWords8) l expected = concatMap unWords8 l in B.pack expected == witnessID (B.concat chunks)- , testProperty "cons b bs == reverse (snoc (reverse bs) b)" $ \(Words8 l) b ->- let b1 = witnessID (B.pack l)- b2 = witnessID (B.pack (reverse l))- expected = B.pack (reverse (B.unpack (B.snoc b2 b)))- in B.cons b b1 == expected- , testProperty "all == Prelude.all" $ \(Words8 l) b ->+ , Property "reverse" $ \(Words8 l) ->+ let b = witnessID (B.pack l)+ in reverse l == B.unpack (B.reverse b)+ , Property "cons b (reverse bs) == reverse (snoc bs b)" $ \(Words8 l) b ->+ let a = witnessID (B.pack l)+ in B.cons b (B.reverse a) == B.reverse (B.snoc a b)+ , Property "all == Prelude.all" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (/= b) in B.all p b1 == all p l- , testProperty "any == Prelude.any" $ \(Words8 l) b ->+ , Property "any == Prelude.any" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (== b) in B.any p b1 == any p l- , testProperty "singleton b == pack [b]" $ \b ->+ , Property "singleton b == pack [b]" $ \b -> witnessID (B.singleton b) == B.pack [b]+ , Property "span" $ \x (Words8 l) ->+ let c = witnessID (B.pack l)+ (a, b) = B.span (== x) c+ in c == B.append a b+ , Property "span (const True)" $ \(Words8 l) ->+ let a = witnessID (B.pack l)+ in B.span (const True) a == (a, B.empty)+ , Property "span (const False)" $ \(Words8 l) ->+ let b = witnessID (B.pack l)+ in B.span (const False) b == (B.empty, b) ]++#ifdef WITH_BASEMENT_SUPPORT+testFoundationTypes = Group "Basement"+ [ CheckPlan "allocRet 4 _ :: UArray Int8 === 4" $ do+ x <- pick "allocateRet 4 _" $ (B.length :: UArray Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ())+ validate "4 === x" $ x === 4+ , CheckPlan "allocRet 4 _ :: UArray Int16 === 4" $ do+ x <- pick "allocateRet 4 _" $ (B.length :: UArray Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ())+ validate "4 === x" $ x === 4+ , CheckPlan "allocRet 4 _ :: UArray Int32 === 4" $ do+ x <- pick "allocateRet 4 _" $ (B.length :: UArray Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ())+ validate "4 === x" $ x === 4+ , CheckPlan "allocRet 4 _ :: UArray Int64 === 8" $ do+ x <- pick "allocateRet 4 _" $ (B.length :: UArray Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ())+ validate "8 === x" $ x === 8+ ]+#endif
tests/Utils.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE CPP #-} module Utils where import Data.Word import Data.ByteArray (Bytes, ScrubbedBytes) +#ifdef WITH_BASEMENT_SUPPORT+import Basement.Block (Block)+import Basement.UArray (UArray)+#endif+ unS :: String -> [Word8] unS = map (fromIntegral . fromEnum) @@ -20,6 +26,14 @@ withScrubbedBytesWitness :: ScrubbedBytes -> ScrubbedBytes withScrubbedBytesWitness = id++#ifdef WITH_BASEMENT_SUPPORT+withBlockWitness :: Block Word8 -> Block Word8+withBlockWitness = withWitness (Witness :: Witness (Block Word8))++withUArrayWitness :: UArray Word8 -> UArray Word8+withUArrayWitness = withWitness (Witness :: Witness (UArray Word8))+#endif numberedList :: [a] -> [(Int, a)] numberedList = zip [1..]