Hello community, here is the log from the commit of package ghc-memory for openSUSE:Factory checked in at 2018-05-30 12:10:36 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-memory (Old) and /work/SRC/openSUSE:Factory/.ghc-memory.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-memory" Wed May 30 12:10:36 2018 rev:10 rq:607834 version:0.14.16 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-memory/ghc-memory.changes 2017-09-15 21:57:20.446619163 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-memory.new/ghc-memory.changes 2018-05-30 12:26:20.116274412 +0200 @@ -1,0 +2,22 @@ +Mon May 14 17:02:11 UTC 2018 - [email protected] + +- Update memory to version 0.14.16. + * Fix compilation with a newer basement (>= 0.0.7) and an older GHC (< 8.0) + * 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 + * Fix bounds issues with empty strings in base64 and base32 + * Improve tests compatibility w.r.t old basement version + * Handle compat SPECIALIZE for older GHC + * Optimise copy operations and convert + * Add instance of ByteArrayAccess and ByteArray for Block + * Add Block and UArray in memory's tests + * Fix issue in unBase64 with an empty bytestring that would cause a segfault + * Reintroduce foundation compatibility with old version + * Reduce dependency to basement + * Fix incompatibility with foundation 0.0.14 + * Fix typo in state passing + +------------------------------------------------------------------- Old: ---- memory-0.14.6.tar.gz New: ---- memory-0.14.16.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-memory.spec ++++++ --- /var/tmp/diff_new_pack.JVOQIc/_old 2018-05-30 12:26:20.904247780 +0200 +++ /var/tmp/diff_new_pack.JVOQIc/_new 2018-05-30 12:26:20.908247646 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-memory # -# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name memory %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.14.6 +Version: 0.14.16 Release: 0 Summary: Memory and related abstraction stuff License: BSD-3-Clause @@ -27,15 +27,11 @@ URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-basement-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-deepseq-devel BuildRequires: ghc-foundation-devel BuildRequires: ghc-rpm-macros -%if %{with tests} -BuildRequires: ghc-tasty-devel -BuildRequires: ghc-tasty-hunit-devel -BuildRequires: ghc-tasty-quickcheck-devel -%endif %description Chunk of memory, polymorphic byte array management and manipulation @@ -83,7 +79,7 @@ %ghc_pkg_recache %files -f %{name}.files -%doc LICENSE +%license LICENSE %files devel -f %{name}-devel.files %doc CHANGELOG.md README.md ++++++ memory-0.14.6.tar.gz -> memory-0.14.16.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/CHANGELOG.md new/memory-0.14.16/CHANGELOG.md --- old/memory-0.14.6/CHANGELOG.md 2017-06-09 23:17:40.000000000 +0200 +++ new/memory-0.14.16/CHANGELOG.md 2018-02-27 07:36:10.000000000 +0100 @@ -1,3 +1,50 @@ +## 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/Bytes.hs new/memory-0.14.16/Data/ByteArray/Bytes.hs --- old/memory-0.14.6/Data/ByteArray/Bytes.hs 2017-04-25 12:50:42.000000000 +0200 +++ new/memory-0.14.16/Data/ByteArray/Bytes.hs 2018-02-26 16:53:56.000000000 +0100 @@ -7,9 +7,11 @@ -- -- Simple and efficient byte array types -- +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.Bytes ( Bytes ) where @@ -17,15 +19,26 @@ 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 -- | 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 +46,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 @@ -124,7 +148,7 @@ (# s'', e2 #) -> if booleanPrim (eqWord# e1 e2) then loop (i +# 1#) s'' - else (# s', False #) + else (# s'', False #) {-# INLINE loop #-} bytesCompare :: Bytes -> Bytes -> Ordering diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/Mapping.hs new/memory-0.14.16/Data/ByteArray/Mapping.hs --- old/memory-0.14.6/Data/ByteArray/Mapping.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/Data/ByteArray/Mapping.hs 2017-09-04 16:13:51.000000000 +0200 @@ -13,7 +13,6 @@ , mapAsWord128 ) where -import Data.Bits (shiftR) import Data.ByteArray.Types import Data.ByteArray.Methods import Data.Memory.Internal.Compat diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/Methods.hs new/memory-0.14.16/Data/ByteArray/Methods.hs --- old/memory-0.14.6/Data/ByteArray/Methods.hs 2017-04-25 12:46:48.000000000 +0200 +++ new/memory-0.14.16/Data/ByteArray/Methods.hs 2018-01-18 17:00:57.000000000 +0100 @@ -5,6 +5,7 @@ -- Stability : stable -- Portability : Good -- +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Data.ByteArray.Methods ( alloc @@ -50,6 +51,14 @@ import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred, last, any, all) import qualified Prelude +#if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_FOUNDATION_SUPPORT) +import qualified Data.ByteString as SPE (ByteString) +import qualified Basement.UArray as SPE (UArray) +#if MIN_VERSION_basement(0,0,5) +import qualified Basement.Block as SPE (Block) +#endif +#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 @@ -223,7 +232,7 @@ copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2 copyAndFreeze bs f = inlineUnsafeCreate (length bs) $ \d -> do - withByteArray bs $ \s -> memCopy d s (length bs) + copyByteArrayToPtr bs d f (castPtr d) {-# NOINLINE copyAndFreeze #-} @@ -290,4 +299,12 @@ -- | 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_FOUNDATION_SUPPORT) +{-# SPECIALIZE convert :: SPE.ByteString -> SPE.UArray Word8 #-} +{-# SPECIALIZE convert :: SPE.UArray Word8 -> SPE.ByteString #-} +#if MIN_VERSION_basement(0,0,5) +{-# SPECIALIZE convert :: SPE.ByteString -> SPE.Block Word8 #-} +{-# SPECIALIZE convert :: SPE.Block Word8 -> SPE.ByteString #-} +#endif +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/ScrubbedBytes.hs new/memory-0.14.16/Data/ByteArray/ScrubbedBytes.hs --- old/memory-0.14.6/Data/ByteArray/ScrubbedBytes.hs 2017-04-25 12:46:48.000000000 +0200 +++ new/memory-0.14.16/Data/ByteArray/ScrubbedBytes.hs 2018-02-26 16:53:56.000000000 +0100 @@ -9,6 +9,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.ScrubbedBytes ( ScrubbedBytes ) where @@ -16,8 +17,14 @@ 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.String (IsString(..)) +import Data.Typeable import Data.Memory.PtrMethods (memCopy, memConstEqual) import Data.Memory.Internal.CompatPrim import Data.Memory.Internal.Compat (unsafeDoIO) @@ -25,6 +32,9 @@ 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: -- @@ -35,6 +45,7 @@ -- * A Eq instance that is constant time -- data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld) + deriving (Typeable) instance Show ScrubbedBytes where show _ = "<scrubbed-bytes>" @@ -43,12 +54,23 @@ (==) = 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/Sized.hs new/memory-0.14.16/Data/ByteArray/Sized.hs --- old/memory-0.14.6/Data/ByteArray/Sized.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/memory-0.14.16/Data/ByteArray/Sized.hs 2018-02-26 11:46:08.000000000 +0100 @@ -0,0 +1,395 @@ +-- | +-- Module : Data.ByteArray.Sized +-- License : BSD-style +-- Maintainer : Nicolas Di Prima <[email protected]> +-- 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 #-} + +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, Semigroup, Monoid) + +-- | 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/ByteArray/Types.hs new/memory-0.14.16/Data/ByteArray/Types.hs --- old/memory-0.14.6/Data/ByteArray/Types.hs 2017-06-09 23:16:37.000000000 +0200 +++ new/memory-0.14.16/Data/ByteArray/Types.hs 2018-02-27 07:10:18.000000000 +0100 @@ -7,6 +7,10 @@ -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Data.ByteArray.Types ( ByteArrayAccess(..) , ByteArray(..) @@ -16,24 +20,72 @@ 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) + + #ifdef WITH_FOUNDATION_SUPPORT + +#if MIN_VERSION_foundation(0,0,14) && MIN_VERSION_basement(0,0,0) +# define NO_LEGACY_FOUNDATION_SUPPORT +#else +# define LEGACY_FOUNDATION_SUPPORT +#endif + +#if MIN_VERSION_basement(0,0,5) +# define SUPPORT_BLOCK +#endif + +#if MIN_VERSION_basement(0,0,7) && __GLASGOW_HASKELL__ >= 800 && defined(SUPPORT_BLOCK) +# define SUPPORT_BLOCKN +#endif + +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.PrimType as Base (primSizeInBytes) + +#ifdef SUPPORT_BLOCK +import qualified Basement.UArray.Mutable as BaseMutable (withMutablePtrHint) +import qualified Basement.Block as Block +import qualified Basement.Block.Mutable as Block +#endif + +#ifdef SUPPORT_BLOCKN +import Basement.Nat +import qualified Basement.Sized.Block as BlockN +#endif + +#ifdef LEGACY_FOUNDATION_SUPPORT + import qualified Foundation as F import qualified Foundation.Collection as F import qualified Foundation.String as F (toBytes, Encoding(UTF8)) import qualified Foundation.Array.Internal as F -import qualified Foundation.Primitive as F +import qualified Foundation.Primitive as F (primSizeInBytes) + #endif +#endif + +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 @@ -45,19 +97,87 @@ -> IO (a, ba) #ifdef WITH_BYTESTRING_SUPPORT -instance ByteArrayAccess B.ByteString where - length = B.length - withByteArray (B.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off) +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_FOUNDATION_SUPPORT -uarrayRecastW8 :: F.PrimType ty => F.UArray ty -> F.UArray F.Word8 + +#if MIN_VERSION_basement(0,0,5) +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) +#endif + +#ifdef SUPPORT_BLOCKN +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) +#endif + +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) +#if MIN_VERSION_basement(0,0,5) + copyByteArrayToPtr ba dst = Base.copyToPtr ba (castPtr dst) +#endif + +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 + +#ifdef SUPPORT_BLOCK +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) +#endif + +instance (Ord ty, Base.PrimType ty) => ByteArray (Base.UArray ty) where + allocRet sz f = do + mba <- Base.new $ sizeRecastBytes sz Proxy +#if MIN_VERSION_basement(0,0,5) + a <- BaseMutable.withMutablePtrHint True False mba (f . castPtr) +#else + a <- Base.withMutablePtr mba (f . castPtr) +#endif + 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 #-} + +#ifdef LEGACY_FOUNDATION_SUPPORT + +uarrayRecastW8 :: F.PrimType ty => F.UArray ty -> F.UArray Word8 uarrayRecastW8 = F.recast instance F.PrimType ty => ByteArrayAccess (F.UArray ty) where @@ -83,24 +203,28 @@ instance (Ord ty, F.PrimType ty) => ByteArray (F.UArray ty) where allocRet sz f = do - mba <- F.new $ sizeRecastBytes sz F.Proxy + mba <- F.new $ sizeRecastBytes sz Proxy a <- F.withMutablePtr mba (f . castPtr) ba <- F.unsafeFreeze mba return (a, ba) where #if MIN_VERSION_foundation(0,0,10) - sizeRecastBytes :: F.PrimType ty => Int -> F.Proxy ty -> F.CountOf ty + sizeRecastBytes :: F.PrimType ty => Int -> Proxy ty -> F.CountOf ty sizeRecastBytes w p = F.CountOf $ let (q,r) = w `Prelude.quotRem` szTy in q + (if r == 0 then 0 else 1) where !(F.CountOf szTy) = F.primSizeInBytes p {-# INLINE [1] sizeRecastBytes #-} #else - sizeRecastBytes :: F.PrimType ty => Int -> F.Proxy ty -> F.Size ty + sizeRecastBytes :: F.PrimType ty => Int -> Proxy ty -> F.Size ty sizeRecastBytes w p = F.Size $ let (q,r) = w `Prelude.quotRem` szTy in q + (if r == 0 then 0 else 1) where !(F.Size szTy) = F.primSizeInBytes p {-# INLINE [1] sizeRecastBytes #-} #endif + +#endif + + #endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/Memory/Encoding/Base32.hs new/memory-0.14.16/Data/Memory/Encoding/Base32.hs --- old/memory-0.14.6/Data/Memory/Encoding/Base32.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/Data/Memory/Encoding/Base32.hs 2018-01-23 15:20:48.000000000 +0100 @@ -58,7 +58,7 @@ -> Int -- index output -> IO () loop i di - | i > len = return () + | i >= len = return () | otherwise = do i1 <- peekByteOff src i i2 <- peekOrZero (i + 1) @@ -111,6 +111,7 @@ -- 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) @@ -250,4 +251,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"# - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/Memory/Encoding/Base64.hs new/memory-0.14.16/Data/Memory/Encoding/Base64.hs --- old/memory-0.14.6/Data/Memory/Encoding/Base64.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/Data/Memory/Encoding/Base64.hs 2018-01-23 15:19:55.000000000 +0100 @@ -104,6 +104,7 @@ -- 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/Data/Memory/Hash/SipHash.hs new/memory-0.14.16/Data/Memory/Hash/SipHash.hs --- old/memory-0.14.6/Data/Memory/Hash/SipHash.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/Data/Memory/Hash/SipHash.hs 2018-02-01 12:54:46.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/README.md new/memory-0.14.16/README.md --- old/memory-0.14.6/README.md 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/README.md 2018-01-23 15:19:55.000000000 +0100 @@ -50,9 +50,11 @@ 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 +* GHC 7.10 +* GHC 8.0 +* GHC 8.2 + +Some older versions or different systems are possibly working too + + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/memory.cabal new/memory-0.14.16/memory.cabal --- old/memory-0.14.6/memory.cabal 2017-06-09 23:18:07.000000000 +0200 +++ new/memory-0.14.16/memory.cabal 2018-02-27 07:34:54.000000000 +0100 @@ -1,5 +1,5 @@ Name: memory -version: 0.14.6 +version: 0.14.16 Synopsis: memory and related abstraction stuff Description: Chunk of memory, polymorphic byte array management and manipulation @@ -25,7 +25,7 @@ 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 @@ -96,7 +96,10 @@ Build-depends: deepseq >= 1.1 if flag(support_foundation) CPP-options: -DWITH_FOUNDATION_SUPPORT - Build-depends: foundation >= 0.0.8 + Build-depends: basement, + foundation >= 0.0.8 + if impl(ghc >= 8.0) + Exposed-modules: Data.ByteArray.Sized ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 @@ -109,12 +112,11 @@ SipHash Utils Build-Depends: base >= 3 && < 5 - , tasty - , tasty-quickcheck - , tasty-hunit + , bytestring , memory + , basement + , foundation >= 0.0.8 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded default-language: Haskell2010 if flag(support_foundation) CPP-options: -DWITH_FOUNDATION_SUPPORT - Build-depends: foundation >= 0.0.8 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/tests/Imports.hs new/memory-0.14.16/tests/Imports.hs --- old/memory-0.14.6/tests/Imports.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/tests/Imports.hs 2018-02-01 12:54:46.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/tests/SipHash.hs new/memory-0.14.16/tests/SipHash.hs --- old/memory-0.14.6/tests/SipHash.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/tests/SipHash.hs 2018-02-01 12:54:46.000000000 +0100 @@ -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 ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/tests/Tests.hs new/memory-0.14.16/tests/Tests.hs --- old/memory-0.14.6/tests/Tests.hs 2017-06-09 23:16:37.000000000 +0200 +++ new/memory-0.14.16/tests/Tests.hs 2018-02-01 12:54:46.000000000 +0100 @@ -1,12 +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 @@ -16,31 +21,52 @@ #ifdef WITH_FOUNDATION_SUPPORT import qualified Foundation as F +#if MIN_VERSION_basement(0,0,5) +import Basement.Block (Block) #endif +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_FOUNDATION_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_FOUNDATION_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 @@ -49,26 +75,32 @@ 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_FOUNDATION_SUPPORT +#if MIN_VERSION_basement(0,0,5) + , Group "Block" (l withBlockWitness) +#endif + , Group "UArray" (l withUArrayWitness) +#endif ] -testShowProperty :: Testable a +testShowProperty :: IsProperty a => String - -> (forall ba . (Show ba, Eq ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a) - -> TestTree + -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a) + -> Test testShowProperty x p = - testGroup x - [ testProperty "Bytes" (p withBytesWitness showLikeString) - , testProperty "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB) + Group x + [ Property "Bytes" (p withBytesWitness showLikeString) + , Property "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB) ] where - showLikeString l = show $ map (chr . fromIntegral) l + showLikeString l = show $ (chr . fromIntegral) <$> l showLikeEmptySB _ = show (withScrubbedBytesWitness B.empty) base64Kats = @@ -77,6 +109,7 @@ , ("easure.", "ZWFzdXJlLg==") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4=") + , ("", "") ] base64URLKats = @@ -108,61 +141,84 @@ ] encodingTests witnessID = - [ testGroup "BASE64" - [ testGroup "encode-KAT" encodeKats64 - , testGroup "decode-KAT" decodeKats64 - ] - , testGroup "BASE64URL" - [ testGroup "encode-KAT" encodeKats64URLUnpadded - , testGroup "decode-KAT" decodeKats64URLUnpadded - ] - , testGroup "BASE32" - [ testGroup "encode-KAT" encodeKats32 - , testGroup "decode-KAT" decodeKats32 - ] - , testGroup "BASE16" - [ testGroup "encode-KAT" encodeKats16 - , testGroup "decode-KAT" decodeKats16 + [ Group "BASE64" + [ Group "encode-KAT" encodeKats64 + , Group "decode-KAT" decodeKats64 + ] + , Group "BASE64URL" + [ Group "encode-KAT" encodeKats64URLUnpadded + , Group "decode-KAT" decodeKats64URLUnpadded + ] + , Group "BASE32" + [ Group "encode-KAT" encodeKats32 + , Group "decode-KAT" decodeKats32 + ] + , 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 @@ -172,69 +228,69 @@ ] 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 -> + , Property "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 "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] - , testProperty "span" $ \x (Words8 l) -> + , Property "span" $ \x (Words8 l) -> let c = witnessID (B.pack l) (a, b) = B.span (== x) c in c == B.append a b - , testProperty "span (const True)" $ \(Words8 l) -> + , Property "span (const True)" $ \(Words8 l) -> let a = witnessID (B.pack l) in B.span (const True) a == (a, B.empty) - , testProperty "span (const False)" $ \(Words8 l) -> + , Property "span (const False)" $ \(Words8 l) -> let b = witnessID (B.pack l) in B.span (const False) b == (B.empty, b) ] #ifdef WITH_FOUNDATION_SUPPORT -testFoundationTypes = testGroup "Foundation" - [ testCase "allocRet 4 _ :: F.UArray Int8 === 4" $ do - x <- (B.length :: F.UArray F.Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ()) - assertEqual "" 4 x - , testCase "allocRet 4 _ :: F.UArray Int16 === 4" $ do - x <- (B.length :: F.UArray F.Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ()) - assertEqual "" 4 x - , testCase "allocRet 4 _ :: F.UArray Int32 === 4" $ do - x <- (B.length :: F.UArray F.Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ()) - assertEqual "" 4 x - , testCase "allocRet 4 _ :: F.UArray Int64 === 8" $ do - x <- (B.length :: F.UArray F.Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ()) - assertEqual "" 8 x +testFoundationTypes = Group "Foundation" + [ CheckPlan "allocRet 4 _ :: F.UArray Int8 === 4" $ do + x <- pick "allocateRet 4 _" $ (B.length :: F.UArray F.Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ()) + validate "4 === x" $ x === 4 + , CheckPlan "allocRet 4 _ :: F.UArray Int16 === 4" $ do + x <- pick "allocateRet 4 _" $ (B.length :: F.UArray F.Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ()) + validate "4 === x" $ x === 4 + , CheckPlan "allocRet 4 _ :: F.UArray Int32 === 4" $ do + x <- pick "allocateRet 4 _" $ (B.length :: F.UArray F.Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ()) + validate "4 === x" $ x === 4 + , CheckPlan "allocRet 4 _ :: F.UArray Int64 === 8" $ do + x <- pick "allocateRet 4 _" $ (B.length :: F.UArray F.Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ()) + validate "8 === x" $ x === 8 ] #endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/memory-0.14.6/tests/Utils.hs new/memory-0.14.16/tests/Utils.hs --- old/memory-0.14.6/tests/Utils.hs 2017-02-21 21:07:31.000000000 +0100 +++ new/memory-0.14.16/tests/Utils.hs 2018-01-18 15:51:46.000000000 +0100 @@ -1,8 +1,15 @@ +{-# LANGUAGE CPP #-} module Utils where import Data.Word import Data.ByteArray (Bytes, ScrubbedBytes) +#ifdef WITH_FOUNDATION_SUPPORT +import qualified Foundation as F +import Basement.Block (Block) +import Basement.UArray (UArray) +#endif + unS :: String -> [Word8] unS = map (fromIntegral . fromEnum) @@ -21,5 +28,13 @@ withScrubbedBytesWitness :: ScrubbedBytes -> ScrubbedBytes withScrubbedBytesWitness = id +#ifdef WITH_FOUNDATION_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..]
