memory 0.14.14 → 0.14.15

raw patch · 10 files changed

+570/−119 lines, 10 filesdep −tastydep −tasty-hunitdep −tasty-quickcheckdep ~basedep ~ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies removed: tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: base, ghc-prim

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• Data/ByteArray/Bytes.hs +11/−0
• Data/ByteArray/ScrubbedBytes.hs +10/−0
• Data/ByteArray/Sized.hs +395/−0
• Data/ByteArray/Types.hs +18/−2
• Data/Memory/Hash/SipHash.hs +3/−1
• memory.cabal +5/−5
• tests/Imports.hs +6/−7
• tests/SipHash.hs +4/−3
• tests/Tests.hs +110/−101

@@ -1,3 +1,11 @@+## 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

@@ -11,6 +11,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.Bytes     ( Bytes     ) where@@ -29,9 +30,15 @@ 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@@ -52,6 +59,10 @@ #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

@@ -9,6 +9,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.ScrubbedBytes     ( ScrubbedBytes     ) where@@ -23,6 +24,7 @@ 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)@@ -30,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: --@@ -40,6 +45,7 @@ -- * A Eq instance that is constant time -- data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld)+  deriving (Typeable)  instance Show ScrubbedBytes where     show _ = "<scrubbed-bytes>"@@ -61,6 +67,10 @@ #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 

@@ -0,0 +1,395 @@+-- |+-- 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 #-}++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

@@ -7,6 +7,10 @@ -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types    #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE UndecidableInstances #-} module Data.ByteArray.Types     ( ByteArrayAccess(..)     , ByteArray(..)@@ -21,6 +25,9 @@ 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)@@ -37,13 +44,15 @@ import qualified Basement.String as Base (String, toBytes, Encoding(UTF8)) import qualified Basement.PrimType as Base (primSizeInBytes) -import           Data.Memory.PtrMethods (memCopy)- #if MIN_VERSION_basement(0,0,5) import qualified Basement.UArray.Mutable as BaseMutable (withMutablePtrHint, copyToPtr) import qualified Basement.Block as Block import qualified Basement.Block.Mutable as Block #endif+#if MIN_VERSION_basement(0,0,7)+import           Basement.Nat+import qualified Basement.BlockN as BlockN+#endif  #ifdef LEGACY_FOUNDATION_SUPPORT @@ -102,6 +111,13 @@     copyByteArrayToPtr ba dst = do         mb <- Block.unsafeThaw (baseBlockRecastW8 ba)         Block.copyToPtr mb 0 (castPtr dst) (Block.length $ baseBlockRecastW8 ba)+#endif++#if MIN_VERSION_basement(0,0,7)+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

@@ -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 

@@ -1,5 +1,5 @@ Name:                memory-version:             0.14.14+version:             0.14.15 Synopsis:            memory and related abstraction stuff Description:     Chunk of memory, polymorphic byte array management and manipulation@@ -98,6 +98,8 @@     CPP-options:     -DWITH_FOUNDATION_SUPPORT     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@@ -111,12 +113,10 @@                      Utils   Build-Depends:     base >= 3 && < 5                    , bytestring-                   , tasty-                   , tasty-quickcheck-                   , tasty-hunit                    , 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:   basement, foundation >= 0.0.8

@@ -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

@@ -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     ]

@@ -1,9 +1,13 @@ {-# 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@@ -23,6 +27,11 @@ 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)@@ -32,32 +41,32 @@ #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 n arbitrary) :: Gen (Block Word8))+        BackendBlock         -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (Block Word8)) #endif-        BackendUArray        -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM n arbitrary) :: Gen (UArray Word8))+        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@@ -66,32 +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)-        , testGroup "Block" (l withBlockWitness)+        , Group "Block" (l withBlockWitness) #endif-        , testGroup "UArray" (l withUArrayWitness)+        , 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 =@@ -132,84 +141,84 @@     ]  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 =-    testGroup "BS-null"-      [ testGroup "BASE64"-        [ testCase "encode-KAT" $ toTest B.Base64-        , testCase "decode-KAT" $ toBackTest B.Base64+    Group "BS-null"+      [ Group "BASE64"+        [ Property "encode-KAT" $ toTest B.Base64+        , Property "decode-KAT" $ toBackTest B.Base64         ]-      , testGroup "BASE32"-        [ testCase "encode-KAT" $ toTest B.Base32-        , testCase "decode-KAT" $ toBackTest B.Base32+      , Group "BASE32"+        [ Property "encode-KAT" $ toTest B.Base32+        , Property "decode-KAT" $ toBackTest B.Base32         ]-      , testGroup "BASE16"-        [ testCase "encode-KAT" $ toTest B.Base16-        , testCase "decode-KAT" $ toBackTest B.Base16+      , Group "BASE16"+        [ Property "encode-KAT" $ toTest B.Base16+        , Property "decode-KAT" $ toBackTest B.Base16         ]       ]   where     toTest base =-      B.convertToBase base BS.empty @=? BS.empty+      B.convertToBase base BS.empty === BS.empty     toBackTest base =-      B.convertFromBase base BS.empty @=? Right BS.empty+      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@@ -219,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