initial implementation of a more comprehensive test suite (#99)

* initial implementation of a more comprehensive test suite

* fix laziness of Eq1 instance. Add Ord1 instance.

* correct the definition of <*>

* Improve compatibility with older versions of GHC and transformers

* add tests for SmallArray and ByteArray. add Eq1, Ord1, and Show1 for SmallArray

* fix implementation of <*> for SmallArray. The previous implementation did a pretty cool trick with a fixed-point combinator, but it didn't work. I couldn't figure out how to make it work, so I just copied the implementation used for Array and adapted it to SmallArray.

* correct foldrByteArray, which fixes the IsList implementation for ByteArray. Also, improve the performance of ByteArray's fromListN function

* improve compatibility with older transformers and base

* add tagged as dependency of test suite so Data.Proxy is available for older GHCs

* use spaces instead of tab in test cabal file

* guard isListLaws with CPP everywhere

* redefine fromList function for small array in test suite

* remove the accidentally exported fromList functions from Data.Primitive.SmallArray

* make fromListN safer for Array, SmallArray, and ByteArray

* make compatible with transformers-0.3.0.0 again

* document changes in changelog

* Bump lower bound for transformers back down to 0.2. Explain the test suite a little in a test suite readme

* allow future releases of quickcheck-classes to be accepted

* document the SmallArray list conversion functions

* add Read1 and Show1 instances for Array and SmallArray. Test Read and Show instances in test suite.

* mention Read1 in changelog

* Start testing Traversable laws. Test foldl1 and foldr1. Fix foldl1 implementation for Array and SmallArray.

* derive Read1 when shimming SmallArray

* For test suite, build quickcheck-classes without aeson and semigroupoids to accelerate travis builds

* pass cabal flags to more places

* remove double quotes from travis environment variable

* try to make travis work again

* fix cabal flags in travis file again

* remove CABAL_FLAGS from travis

Author: andrewthad

Data/Primitive/Array.hs

@@ -63,6 +63,10 @@ import Data.Functor.Identity
 
 import Text.ParserCombinators.ReadP
 
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))
+#endif
+
 -- | Boxed arrays
 data Array a = Array
   { array# :: Array# a }
@@ -288,26 +292,50 @@ createArray n x f = runST $ do
 die :: String -> String -> a
 die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem
 
+arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool
+arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1)
+  where loop i | i < 0     = True
+               | (# x1 #) <- indexArray## a1 i
+               , (# x2 #) <- indexArray## a2 i
+               , otherwise = p x1 x2 && loop (i-1)
+
 instance Eq a => Eq (Array a) where
-  a1 == a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1)
-   where loop i | i < 0     = True
-                | (# x1 #) <- indexArray## a1 i
-                , (# x2 #) <- indexArray## a2 i
-                = x1 == x2 && loop (i-1)
+  a1 == a2 = arrayLiftEq (==) a1 a2
+
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+instance Eq1 Array where
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
+  liftEq = arrayLiftEq
+#else
+  eq1 = arrayLiftEq (==)
+#endif
+#endif
 
 instance Eq (MutableArray s a) where
   ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2))
 
+arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering
+arrayLiftCompare elemCompare a1 a2 = loop 0
+  where
+  mn = sizeofArray a1 `min` sizeofArray a2
+  loop i
+    | i < mn
+    , (# x1 #) <- indexArray## a1 i
+    , (# x2 #) <- indexArray## a2 i
+    = elemCompare x1 x2 `mappend` loop (i+1)
+    | otherwise = compare (sizeofArray a1) (sizeofArray a2)
+
 instance Ord a => Ord (Array a) where
-  compare a1 a2 = loop 0
-   where
-   mn = sizeofArray a1 `min` sizeofArray a2
-   loop i
-     | i < mn
-     , (# x1 #) <- indexArray## a1 i
-     , (# x2 #) <- indexArray## a2 i
-     = compare x1 x2 `mappend` loop (i+1)
-     | otherwise = compare (sizeofArray a1) (sizeofArray a2)
+  compare a1 a2 = arrayLiftCompare compare a1 a2
+
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+instance Ord1 Array where
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
+  liftCompare = arrayLiftCompare
+#else
+  compare1 = arrayLiftCompare compare
+#endif
+#endif
 
 instance Foldable Array where
   -- Note: we perform the array lookups eagerly so we won't
@@ -347,7 +375,7 @@ instance Foldable Array where
       go i =
         case indexArray## ary i of
           (# x #) | i == 0 -> x
-                  | otherwise -> f x (go (i - 1))
+                  | otherwise -> f (go (i - 1)) x
     in if sz < 0
        then die "foldl1" "empty array"
        else go sz
@@ -478,26 +506,35 @@ unsafeTraverseArray f = \ !ary ->
     go 0 mary
 {-# INLINE unsafeTraverseArray #-}
 
+arrayFromListN :: Int -> [a] -> Array a
+arrayFromListN n l = runST $ do
+  sma <- newArray n (die "fromListN" "uninitialized element")
+  let go !ix [] = if ix == n
+        then return ()
+        else die "fromListN" "list length less than specified size"
+      go !ix (x : xs) = if ix < n
+        then do
+          writeArray sma ix x
+          go (ix+1) xs
+        else die "fromListN" "list length greater than specified size"
+  go 0 l
+  unsafeFreezeArray sma
+
+arrayFromList :: [a] -> Array a
+arrayFromList l = arrayFromListN (length l) l
+
 #if MIN_VERSION_base(4,7,0)
 instance Exts.IsList (Array a) where
   type Item (Array a) = a
-  fromListN n l =
-    createArray n (die "fromListN" "mismatched size and list") $ \mi ->
-      let go i (x:xs) = writeArray mi i x >> go (i+1) xs
-          go _ [    ] = return ()
-       in go 0 l
-  fromList l = Exts.fromListN (length l) l
+  fromListN = arrayFromListN
+  fromList = arrayFromList
   toList = toList
 #else
 fromListN :: Int -> [a] -> Array a
-fromListN n l =
-  createArray n (die "fromListN" "mismatched size and list") $ \mi ->
-    let go i (x:xs) = writeArray mi i x >> go (i+1) xs
-        go _ [    ] = return ()
-     in go 0 l
+fromListN = arrayFromListN
 
 fromList :: [a] -> Array a
-fromList l = fromListN (length l) l
+fromList = arrayFromList
 #endif
 
 instance Functor Array where
@@ -526,6 +563,7 @@ instance Applicative Array where
             do
               x <- indexArrayM a j
               writeArray mb (off + j) (f x)
+              go2 off f (j + 1)
     go1 0
     unsafeFreezeArray mb
    where szab = sizeofArray ab ; sza = sizeofArray a
@@ -649,19 +687,48 @@ instance Monoid (Array a) where
      in go 0 l
    where sz = sum . fmap sizeofArray $ l
 
+arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS
+arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $
+  showString "fromListN " . shows (sizeofArray a) . showString " "
+    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a)
+
+-- this need to be included for older ghcs
+listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS
+listLiftShowsPrec _ sl _ = sl
+
 instance Show a => Show (Array a) where
-  showsPrec p a = showParen (p > 10) $
-    showString "fromListN " . shows (sizeofArray a) . showString " "
-      . shows (toList a)
+  showsPrec p a = arrayLiftShowsPrec showsPrec showList p a
+
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+instance Show1 Array where
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
+  liftShowsPrec = arrayLiftShowsPrec
+#else
+  showsPrec1 = arrayLiftShowsPrec showsPrec showList
+#endif
+#endif
+
+arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a)
+arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do
+  () <$ string "fromListN"
+  skipSpaces
+  n <- readS_to_P reads
+  skipSpaces
+  l <- readS_to_P listReadsPrec
+  return $ arrayFromListN n l
 
 instance Read a => Read (Array a) where
-  readsPrec p = readParen (p > 10) . readP_to_S $ do
-    () <$ string "fromListN"
-    skipSpaces
-    n <- readS_to_P reads
-    skipSpaces
-    l <- readS_to_P reads
-    return $ fromListN n l
+  readsPrec = arrayLiftReadsPrec readsPrec readList
+
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+instance Read1 Array where
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
+  liftReadsPrec = arrayLiftReadsPrec
+#else
+  readsPrec1 = arrayLiftReadsPrec readsPrec readList
+#endif
+#endif
+
 
 arrayDataType :: DataType
 arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr]

Data/Primitive/ByteArray.hs

@@ -44,7 +44,6 @@ module Data.Primitive.ByteArray (
 
 import Control.Monad.Primitive
 import Control.Monad.ST
-import Control.Monad ( zipWithM_ )
 import Data.Primitive.Types
 
 import Foreign.C.Types
@@ -181,12 +180,20 @@ foldrByteArray f z arr = go 0
     go i
       | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))
       | otherwise                    = z
-    sz = sizeofByteArray arr
+    sz = sizeOf (undefined :: a)
 
 fromListN :: Prim a => Int -> [a] -> ByteArray
-fromListN n xs = runST $ do
-    marr <- newByteArray (n * sizeOf (head xs))
-    zipWithM_ (writeByteArray marr) [0..n] xs
+fromListN n ys = runST $ do
+    marr <- newByteArray (n * sizeOf (head ys))
+    let go !ix [] = if ix == n
+          then return ()
+          else die "fromListN" "list length less than specified size"
+        go !ix (x : xs) = if ix < n 
+          then do
+            writeByteArray marr ix x
+            go (ix + 1) xs
+          else die "fromListN" "list length greater than specified size"
+    go 0 ys
     unsafeFreezeByteArray marr
 
 #if __GLASGOW_HASKELL__ >= 702
@@ -444,3 +451,7 @@ instance Exts.IsList ByteArray where
   fromList xs = fromListN (length xs) xs
   fromListN = fromListN
 #endif
+
+die :: String -> String -> a
+die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem
+