Add a basic test for ByteArray's Monoid instance

2 files changed, 84 insertions, 0 deletions

diff --git a/testsuite/tests/lib/base/Monoid_ByteArray.hs b/testsuite/tests/lib/base/Monoid_ByteArray.hs
new file mode 100644
index 0000000000..0fe9e91a8b
--- /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 18c3f5814f..5e3cf28f68 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, [''])