From 2004e3c87b6b1e486d83fefb6d187039ad461093 Mon Sep 17 00:00:00 2001
From: Matthew Craven <5086-clyring@users.noreply.gitlab.haskell.org>
Date: Thu, 2 Jun 2022 19:24:00 -0400
Subject: [PATCH] Add a basic test for ByteArray's Monoid instance
---
testsuite/tests/lib/base/Monoid_ByteArray.hs | 83 ++++++++++++++++++++
testsuite/tests/lib/base/all.T | 1 +
2 files changed, 84 insertions(+)
create mode 100644 testsuite/tests/lib/base/Monoid_ByteArray.hs
diff --git a/testsuite/tests/lib/base/Monoid_ByteArray.hs b/testsuite/tests/lib/base/Monoid_ByteArray.hs
new file mode 100644
index 000000000000..0fe9e91a8bd3
--- /dev/null
+++ b/testsuite/tests/lib/base/Monoid_ByteArray.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE DerivingVia, TypeApplications, OverloadedLists #-}
+
+module Main where
+
+import Control.Exception
+import Control.Monad
+import Data.Array.Byte
+import Data.Bits
+import Data.Either
+import Data.List (tails)
+import Data.Ord
+import Data.Semigroup
+import GHC.Exts (IsList(..))
+
+
+newtype Tricky = Tricky Int
+ deriving (Eq, Num, Real, Enum, Integral) via Int
+ deriving Ord via Down Int
+
+smallArrs :: [ByteArray]
+-- 40 arrays, of total length 600
+smallArrs = [[], [3,8,1], [0], [255], [1,6,1,8,2]] ++
+ map fromList (replicate 29 0 : tails [0..32])
+
+shouldError :: a -> IO () -> IO ()
+shouldError val ifNoError = do
+ res <- try @ErrorCall (evaluate val)
+ when (isRight res) ifNoError
+
+testConcat :: [ByteArray] -> IO ()
+testConcat arrs = do
+ let lis = map toList arrs
+ expected = mconcat lis
+ actual = toList (mconcat arrs)
+ when (expected /= actual) $
+ putStrLn $ unwords ["mconcat", show lis, "/=", show actual]
+
+main :: IO ()
+main = do
+ when (toList @ByteArray mempty /= []) $
+ putStrLn "mempty /= []"
+
+ -- test <>
+ forM_ smallArrs $ \x -> do
+ let xli = toList x
+ forM_ smallArrs $ \y -> do
+ let yli = toList y
+ expected = xli <> yli
+ actual = toList (x <> y)
+ when (expected /= actual) $
+ putStrLn $ unwords [show xli, "<>", show yli, "/=", show actual]
+
+ -- test stimes
+ forM_ smallArrs $ \x -> do
+ let xli = toList x
+ shouldError (stimes (-1 :: Integer) x) $
+ putStrLn $ unwords ["stimes (-1 :: Integer)", show xli, "didn't fail??"]
+ shouldError (stimes (-1 :: Tricky) x) $
+ putStrLn $ unwords ["stimes (-1 :: Tricky)", show xli, "didn't fail??"]
+ when (length xli > 1) $ shouldError (stimes (maxBound @Int) x) $
+ putStrLn $ unwords ["stimes (maxBound @Int)", show xli, "didn't fail??"]
+ forM_ (10000 : [0 :: Int .. 32]) $ \n -> do
+ let expected = stimes n xli
+ actual = toList (stimes n x)
+ when (expected /= actual) $
+ putStrLn $ unwords ["stimes", show n, show xli, "/=", show actual]
+ evaluate $ stimes @ByteArray @Int maxBound []
+ evaluate $ stimes @ByteArray @Integer (10^100) []
+
+ -- test mconcat
+ testConcat []
+ forM_ smallArrs $ \x -> do
+ testConcat [x]
+ forM_ smallArrs $ \y -> do
+ testConcat [x, y]
+ forM_ smallArrs $ \z -> do -- OK, 40^3 = 64K
+ testConcat [x, y, z]
+
+ -- test mconcat's overflow-handling
+ let bigArr = stimes (bit 18 :: Int) [0] :: ByteArray
+ when (finiteBitSize @Int 0 == 32) $
+ shouldError (mconcat $ replicate (bit 14) bigArr) $
+ putStrLn "Impossible mconcat succeeded???"
diff --git a/testsuite/tests/lib/base/all.T b/testsuite/tests/lib/base/all.T
index 18c3f5814f93..5e3cf28f686b 100644
--- a/testsuite/tests/lib/base/all.T
+++ b/testsuite/tests/lib/base/all.T
@@ -7,3 +7,4 @@ test('T19691', normal, compile, [''])
test('executablePath', extra_run_opts(config.os), compile_and_run, [''])
test('T17472', normal, compile_and_run, [''])
test('T19569b', normal, compile_and_run, [''])
+test('Monoid_ByteArray', normal, compile_and_run, [''])
--
GitLab