diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Kuleshevich (c) 2017-2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexey Kuleshevich nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +# massiv-test + +This package is designed for users of `massiv`, that would like to do some testing of +their code, while reusing functionality that has already been written for testing `massiv` +itsef. This library is still a work in progress, nevertheless it is at a fairly usable +state. Below is a list of use case for this package. + +## QuickCheck generators + +First and foremost this package provides `Arbitrary` and `CoArbitrary` instances for the +relevant types available in `massiv`, as well as few extra handy `newtype` wrappers that +can be very useful for writing property tests for libraries and applications that depends +on `massiv`. + +## Reusable spec + +Another important use case is for advanced users that came up with their own index types +or array representations and would like to run a standard set of specs on their instance +implementations. For example a custom `Index ix`, or `Mutable r ix e` instances can use a +predefined collection of `hspec` specs and/or `QuickCheck` properties to validate their +implementation. + +## Test suite for `massiv` + +Internally `massiv-test` package contains all of the tests that are used on `massiv`. The +whole test suite has been extracted out to make the `massiv` package lighter as well as to +make the test functionality reusable, without impacting the dependency footprint of the +user that does not need the testing functionlity. + +Because of this usecase, the major version of `massiv-test` is expected to increase with +almost every release of `massiv`. + +## Doctests + +Together with examples in haddock it is possible to describe various properties. Those +examples and properties can be tested with doctests, but such properties can not be tested +without QuickCheck generators readily available for import, for that reason `doctest` test +section of `massiv` also depends on `massiv-test`. + +# More info + +For more info on `massiv` and related libraries refer to +[README](https://github.com/lehins/massiv/blob/master/README.md) on github. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/massiv-test.cabal b/massiv-test.cabal new file mode 100644 --- /dev/null +++ b/massiv-test.cabal @@ -0,0 +1,95 @@ +name: massiv-test +version: 0.1.0 +synopsis: Library that contains generators, properties and tests for Massiv Array Library. +description: This library is designed for users of massiv library that need random generators for writing custom property tests and reusing some of the predefined ones. +homepage: https://github.com/lehins/massiv +license: BSD3 +license-file: LICENSE +author: Alexey Kuleshevich +maintainer: alexey@kuleshevi.ch +copyright: 2018-2019 Alexey Kuleshevich +category: Data, Data Structures, Parallelism +build-type: Simple +extra-source-files: README.md + , CHANGELOG.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Test.Massiv.Core + , Test.Massiv.Core.Common + , Test.Massiv.Core.Index + , Test.Massiv.Core.Mutable + , Test.Massiv.Array.Mutable + , Test.Massiv.Utils + + + build-depends: base >= 4.9 && < 5 + , bytestring + , data-default-class + , deepseq + , exceptions + , QuickCheck + , hspec + , massiv == 0.4.* + , scheduler + , primitive + , unliftio + , vector + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Spec + , Test.Massiv.Core.IndexSpec + , Test.Massiv.Core.SchedulerSpec + , Test.Massiv.Array.MutableSpec + -- TODO: Below should be moved to Test.Massiv.Array + , Data.Massiv.Array.Delayed.InterleavedSpec + , Data.Massiv.Array.Delayed.PushSpec + , Data.Massiv.Array.Delayed.WindowedSpec + , Data.Massiv.Array.DelayedSpec + , Data.Massiv.Array.Manifest.VectorSpec + , Data.Massiv.Array.ManifestSpec + , Data.Massiv.Array.Numeric.IntegralSpec + , Data.Massiv.Array.Ops.ConstructSpec + , Data.Massiv.Array.Ops.FoldSpec + , Data.Massiv.Array.Ops.MapSpec + , Data.Massiv.Array.Ops.SliceSpec + , Data.Massiv.Array.Ops.SortSpec + , Data.Massiv.Array.Ops.TransformSpec + , Data.Massiv.Array.StencilSpec + , Data.Massiv.ArraySpec + build-depends: base + , bytestring + , containers + , data-default + , deepseq + , genvalidity-hspec + , massiv + , massiv-test + , hspec + , scheduler + , QuickCheck + , vector + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + -with-rtsopts=-N2 + +source-repository head + type: git + location: https://github.com/lehins/massiv diff --git a/src/Test/Massiv/Array/Mutable.hs b/src/Test/Massiv/Array/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Array/Mutable.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Massiv.Array.Mutable + ( -- * Spec for safe Mutable instance + mutableSpec + , prop_GenerateArray + , prop_iMapiMapM + -- * Atomic ops spec + , atomicIntSpec + ) where + +import UnliftIO.Async +import Data.Bits +import Data.Functor.Identity +import Data.List as L +import Data.Massiv.Array as A +import Data.Massiv.Array.Mutable.Atomic +import Data.Massiv.Array.Unsafe +import Test.Massiv.Core.Common +import Test.Massiv.Utils as T + + +-- prop_MapMapM :: forall r ix(Show (Array r ix Word), Eq (Array r ix Word), Mutable r ix Word) => +-- Fun Word Word -> ArrTiny D ix Word -> Property +-- prop_MapMapM r _ f (ArrTiny arr) = +-- computeAs r (A.map (apply f) arr) === runIdentity (A.mapMR r (return . apply f) arr) + +prop_iMapiMapM :: + forall r ix e. (Show (Array r ix e), Eq (Array r ix e), Mutable r ix e) + => Fun (ix, e) e + -> Array D ix e + -> Property +prop_iMapiMapM f arr = + (compute (A.imap (curry (apply f)) arr) :: Array r ix e) === + runIdentity (A.imapM (\ix e -> pure $ apply f (ix, e)) arr) + +prop_GenerateArray :: + forall r ix e. + ( Show (Array r ix e) + , Eq (Array r ix e) + , Mutable r ix e + , Show e + , Arbitrary e + , Arbitrary ix + , Function ix + , CoArbitrary ix + ) + => Property +prop_GenerateArray = + property $ \comp sz f' -> do + let arr = makeArray comp sz f :: Array r ix e + arrST = runST (generateArrayS (size arr) (return . evaluate' arr)) + f = apply f' + arrST `shouldBe` arr + arrIO <- generateArray (getComp arr) (size arr) (evaluateM arr) + arrIO `shouldBe` arr + +prop_Shrink :: + forall r ix e. + ( Show (Array r ix e) + , Mutable r ix e + , Resize r ix + , Source r Ix1 e + , Arbitrary ix + , Arbitrary e + , Eq e + ) + => Property +prop_Shrink = + property $ \ (ArrIx arr ix) -> runST $ do + marr :: MArray s r ix e <- thawS arr + sarr <- unsafeFreeze (getComp arr) =<< unsafeLinearShrink marr (Sz ix) + pure (A.foldlS (.&&.) (property True) $ A.zipWith (==) (flatten arr) (flatten sarr)) + +prop_GrowShrink :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Load (R r) ix e + , Mutable r ix e + , Extract r ix e + , Arbitrary ix + , Arbitrary e + , Show e + ) + => Property +prop_GrowShrink = + property $ \ (ArrNE arr) (NonNegative delta) e -> runST $ do + let sz = size (arr :: Array r ix e) + k = getDim' (unSz sz) (dimensions sz) + -- increase the outer most dimension, just so the structure doesn't change + newSz = Sz $ setDim' (unSz sz) (dimensions sz) (k + delta) + marr <- thawS arr + grownMarr <- unsafeLinearGrow marr newSz + -- Make sure we can write into the newly allocated area + when (delta > 0) $ void $ write grownMarr (liftIndex pred (unSz newSz)) e + garr <- compute . extract' zeroIndex sz <$> unsafeFreeze (getComp arr) grownMarr + sarr <- freezeS =<< unsafeLinearShrink grownMarr sz + pure (garr === arr .&&. sarr === arr) + + + +prop_unfoldrList :: + forall r ix e. + ( Show (Array r Ix1 e) + , Eq (Array r Ix1 e) + , Arbitrary ix + , Arbitrary e + , Show e + , Resize r ix + , Mutable r ix e + , Mutable r Ix1 e + ) + => Property +prop_unfoldrList = + property $ \comp sz f (i :: Word) -> + let xs = runST (unfoldrPrimM_ comp sz (pure . apply f) i) :: Array r ix e + ys = A.fromList comp (L.take (totalElem sz) (L.unfoldr (Just . apply f) i)) + in flatten xs === ys + + +prop_unfoldrReverseUnfoldl :: + forall r ix e. + ( Show (Array r ix e) + , Eq (Array r ix e) + , Arbitrary ix + , Arbitrary e + , Show e + , Source r ix e + , Mutable r ix e + ) + => Property +prop_unfoldrReverseUnfoldl = + property $ \ comp sz f (i :: Word) -> + let swapTuple (x, y) = (y, x) + rev a = + compute @r (backpermute' sz (liftIndex pred . liftIndex2 (-) (unSz sz)) a) + in do a1 :: Array r ix e <- unfoldrPrimM_ @r comp sz (pure . apply f) i + a2 <- unfoldlPrimM_ @r comp sz (pure . swapTuple . apply f) i + rev a1 `shouldBe` a2 + + +mutableSpec :: + forall r ix e. + ( Show (Array D ix e) + , Show (Array r ix e) + , Show (Array r Ix1 e) + , Eq (Array r Ix1 e) + , Load (R r) ix e + , Eq (Array r ix e) + , Typeable e + , Show e + , Eq e + , Mutable r ix e + , Mutable r Ix1 e + , Extract r ix e + , Resize r ix + , CoArbitrary ix + , Arbitrary e + , CoArbitrary e + , Arbitrary ix + , Typeable ix + , Function ix + , Function e + ) + => Spec +mutableSpec = do + describe ("Mutable (" ++ showsArrayType @r @ix @e ") (Safe)") $ do + it "GenerateArray" $ property $ prop_GenerateArray @r @ix @e + it "Shrink" $ property $ prop_Shrink @r @ix @e + it "GrowShrink" $ property $ prop_GrowShrink @r @ix @e + it "map == mapM" $ property $ prop_iMapiMapM @r @ix @e + describe "Unfolding" $ do + it "unfoldrList" $ prop_unfoldrList @r @ix @e + it "unfoldrReverseUnfoldl" $ prop_unfoldrReverseUnfoldl @r @ix @e + + + +-- | Try to write many elements into the same array cell concurrently, while keeping the +-- previous element for each write. With atomic writes, not a single element should be lost. +prop_atomicModifyIntArrayMany :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => Property +prop_atomicModifyIntArrayMany = + property $ \(ArrIx arr ix) (ys :: Array B Ix1 Int) -> do + marr <- thaw arr + atomicModifyIntArray marr (liftIndex (subtract 1 . negate) ix) succ `shouldReturn` Nothing + mys <- mapConcurrently (atomicModifyIntArray marr ix . const) ys + x <- A.readM marr (ix :: ix) + let xs = x : fromMaybe (error "atomicModifyIntArray") (Prelude.sequenceA (toList mys)) + y <- indexM arr ix + L.sort (y : toList ys) `shouldBe` L.sort xs + +prop_atomicReadIntArray :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => Property +prop_atomicReadIntArray = + property $ \arr (ix :: ix) -> do + marr <- unsafeThaw arr + mx <- A.read marr ix + atomicReadIntArray marr ix `shouldReturn` mx + +prop_atomicWriteIntArray :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => Property +prop_atomicWriteIntArray = + property $ \arr (ix :: ix) (e :: Int) -> do + marr <- unsafeThaw arr + mx <- A.read marr ix + atomicWriteIntArray marr ix e `shouldReturn` isJust mx + T.forM_ mx $ \ _ -> + A.read marr ix `shouldReturn` Just e + +prop_atomicOpIntArray :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => (Int -> Int -> Int) + -> (forall m. PrimMonad m => + MArray (PrimState m) P ix Int -> ix -> Int -> m (Maybe Int)) + -> Property +prop_atomicOpIntArray f atomicAction = + property $ \arr (ix :: ix) (e :: Int) -> do + marr <- unsafeThaw arr + mx <- A.read marr ix + atomicAction marr ix e `shouldReturn` mx + T.forM_ mx $ \x -> A.readM marr ix `shouldReturn` f x e + +prop_casIntArray :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => Property +prop_casIntArray = + property $ \arr (ix :: ix) (e :: Int) -> do + marr <- unsafeThaw arr + mx <- A.read marr ix + case mx of + Nothing -> casIntArray marr ix e e `shouldReturn` Nothing + Just x -> do + casIntArray marr ix x e `shouldReturn` mx + A.readM marr ix `shouldReturn` e + + +atomicIntSpec :: + forall ix. (Show (Array P ix Int), Arbitrary ix, Index ix) + => Spec +atomicIntSpec = + describe "Atomic Int Operations" $ do + it "atomicModifyIntArrayMany" $ prop_atomicModifyIntArrayMany @ix + it "atomicReadIntArray" $ prop_atomicReadIntArray @ix + it "atomicWriteIntArray" $ prop_atomicWriteIntArray @ix + it "atomicAddIntArray" $ prop_atomicOpIntArray @ix (+) atomicAddIntArray + it "atomicSubIntArray" $ prop_atomicOpIntArray @ix (-) atomicSubIntArray + it "atomicAndIntArray" $ prop_atomicOpIntArray @ix (.&.) atomicAndIntArray + it "atomicNandIntArray" $ + prop_atomicOpIntArray @ix (\x y -> complement (x .&. y)) atomicNandIntArray + it "atomicOrIntArray" $ prop_atomicOpIntArray @ix (.|.) atomicOrIntArray + it "atomicXorIntArray" $ prop_atomicOpIntArray @ix xor atomicXorIntArray + it "casIntArray" $ prop_casIntArray @ix diff --git a/src/Test/Massiv/Core.hs b/src/Test/Massiv/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Core.hs @@ -0,0 +1,9 @@ +module Test.Massiv.Core + ( module Index + , module Commmon + , module Utils + ) where + +import Test.Massiv.Core.Index as Index (DimIx(..), SzIx(..), SzNE(..)) +import Test.Massiv.Core.Common as Commmon +import Test.Massiv.Utils as Utils diff --git a/src/Test/Massiv/Core/Common.hs b/src/Test/Massiv/Core/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Core/Common.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Test.Massiv.Core.Common + ( ArrNE(..) + , ArrTiny(..) + , ArrTinyNE(..) + , ArrIx(..) + , module X + ) where + +import Data.Massiv.Array +import Test.Massiv.Core.Index as X +import Test.Massiv.Utils + + + + +-- | Arbitrary non-empty array. Computation strategy can be either `Seq` or `Par`. +-- +-- @since 0.1.0 +newtype ArrNE r ix e = ArrNE + { unArr :: Array r ix e + } + +-- | Arbitrary small and possibly empty array. Computation strategy can be either `Seq` or `Par`. +-- +-- @since 0.1.0 +newtype ArrTiny r ix e = ArrTiny + { unArrTiny :: Array r ix e + } + +-- | Tiny but non-empty +-- +-- @since 0.1.0 +newtype ArrTinyNE r ix e = ArrTinyNE + { unArrTinyNE :: Array r ix e + } + +-- | Arbitrary non-empty array with a valid index. Can be either `Seq` or `Par` +-- +-- @since 0.1.0 +data ArrIx r ix e = ArrIx (Array r ix e) ix + +deriving instance (Show (Array r ix e)) => Show (ArrNE r ix e) +deriving instance (Show (Array r ix e)) => Show (ArrTiny r ix e) +deriving instance (Show (Array r ix e)) => Show (ArrTinyNE r ix e) +deriving instance (Show (Array r ix e), Show ix) => Show (ArrIx r ix e) + + + +instance Arbitrary Comp where + arbitrary = + frequency + [ (20, pure Seq) + , (10, pure Par) + , (15, ParOn <$> arbitrary) + , (15, ParN . getSmall <$> arbitrary) + ] + + +arbitraryArray :: (Construct r ix e, Arbitrary e) => Gen (Sz ix) -> Gen (Array r ix e) +arbitraryArray szGen = makeArrayLinear <$> arbitrary <*> szGen <*> arbitrary + +-- | Arbitrary array +instance (Arbitrary ix, Construct r ix e, Arbitrary e) => + Arbitrary (Array r ix e) where + arbitrary = makeArrayLinear <$> arbitrary <*> arbitrary <*> arbitrary + + +instance (Arbitrary ix, Construct r ix e, Arbitrary e) => Arbitrary (ArrTiny r ix e) where + arbitrary = ArrTiny <$> arbitraryArray (liftSz (`mod` 10) <$> arbitrary) + +-- | Arbitrary small and possibly empty array. Computation strategy can be either `Seq` or `Par`. +instance (Arbitrary ix, Construct r ix e, Arbitrary e) => + Arbitrary (ArrTinyNE r ix e) where + arbitrary = ArrTinyNE <$> arbitraryArray (liftSz (succ . (`mod` 10)) <$> arbitrary) + +instance (Arbitrary ix, Construct r ix e, Arbitrary e) => + Arbitrary (ArrNE r ix e) where + arbitrary = ArrNE <$> arbitraryArray (unSzNE <$> arbitrary) + + +instance (Arbitrary ix, Construct r ix e, Arbitrary e) => + Arbitrary (ArrIx r ix e) where + arbitrary = do + SzIx sz ix <- arbitrary + func <- arbitrary + comp <- arbitrary + return $ ArrIx (makeArrayLinear comp sz func) ix diff --git a/src/Test/Massiv/Core/Index.hs b/src/Test/Massiv/Core/Index.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Core/Index.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +module Test.Massiv.Core.Index + ( DimIx(..) + , SzNE(..) + , SzIx(..) + , ixToList + , arbitraryIx1 + , toIx + -- * Specs + -- ** Index + , specIx1 + , ixSpec + , ix2UpSpec + , ixNumSpec + -- ** Size + , szNumSpec + , szSpec + -- * Re-exports + , module Data.Massiv.Core.Index + ) where + +import Control.DeepSeq +import Control.Exception (throw) +import Control.Monad +import Data.Foldable as F +import Data.Functor.Identity +import Data.IORef +import Data.Massiv.Array.Unsafe (Sz(SafeSz)) +import Data.Massiv.Core.Index +import Data.Proxy +import Data.Typeable +import Test.Massiv.Utils + + +-- | Dimension that is always within bounds of an index +newtype DimIx ix = DimIx Dim deriving Show + +deriving instance Arbitrary Dim + +-- | Size that will result in a non-empty array. +-- +-- prop > \ (neSz :: Sz1) -> totalElem (unSzNE neSz) > 0 +-- prop > \ (neSz :: Sz2) -> totalElem (unSzNE neSz) > 0 +-- prop > \ (neSz :: Sz3) -> totalElem (unSzNE neSz) > 0 +-- prop > \ (neSz :: Sz4) -> totalElem (unSzNE neSz) > 0 +-- prop > \ (neSz :: Sz5) -> totalElem (unSzNE neSz) > 0 +newtype SzNE ix = SzNE + { unSzNE :: Sz ix + } deriving (Show) + + +-- | Non-empty size together with an index that is within bounds of that index. +data SzIx ix = SzIx (Sz ix) ix deriving Show + +instance (Index ix, Arbitrary ix) => Arbitrary (Sz ix) where + arbitrary = do + sz <- Sz . liftIndex abs <$> arbitrary + if totalElem sz > 50000 + then arbitrary + else return sz + +instance (Index ix, Arbitrary ix) => Arbitrary (SzNE ix) where + arbitrary = SzNE . Sz . liftIndex (+1) . unSz <$> arbitrary + +instance (Index ix, Arbitrary ix) => Arbitrary (Stride ix) where + arbitrary = do + Positive (Small x) <- arbitrary + Stride . liftIndex ((+1) . (`mod` min 6 x)) <$> arbitrary + +instance (Index ix, Arbitrary ix) => Arbitrary (SzIx ix) where + arbitrary = do + SzNE sz <- arbitrary + -- Make sure index is within bounds: + SzIx sz . flip (liftIndex2 mod) (unSz sz) <$> arbitrary + + +instance Arbitrary e => Arbitrary (Border e) where + arbitrary = + oneof + [ Fill <$> arbitrary + , return Wrap + , return Edge + , return Reflect + , return Continue + ] + + +instance Index ix => Arbitrary (DimIx ix) where + arbitrary = do + n <- arbitrary + return $ DimIx (1 + (Dim n `mod` dimensions (Proxy :: Proxy ix))) + +-- | Generators are quadratic in QuickCheck. Unlike built-in Arbitrary instance for `Int`, +-- this one generates smaller integers +-- +-- @since 0.1.0 +arbitraryIx1 :: Gen Int +arbitraryIx1 = sized (\s -> resize (floor $ (sqrt :: Double -> Double) $ fromIntegral s) arbitrary) + +-- | Convert an index to a list +-- +-- @since 0.1.0 +ixToList :: Index ix => ix -> [Int] +ixToList = reverse . foldlIndex (flip (:)) [] + +-- | A fairly slow way to convert from one arbitrary index to another of the same dimension +-- +-- @since 0.1.0 +toIx :: + forall ix' ix. (Dimensions ix' ~ Dimensions ix, Index ix', Index ix) + => ix + -> ix' +toIx ix = F.foldl' setEachIndex zeroIndex [1 .. dimensions (Sz ix)] + where + setEachIndex ix' d = setDim' ix' d (getDim' ix d) + +instance Arbitrary Ix0 where + arbitrary = pure Ix0 + +instance Arbitrary Ix2 where + arbitrary = (:.) <$> arbitraryIx1 <*> arbitraryIx1 + +instance Arbitrary Ix3 where + arbitrary = (:>) <$> arbitraryIx1 <*> ((:.) <$> arbitraryIx1 <*> arbitraryIx1) + +instance Arbitrary Ix4 where + arbitrary = (:>) <$> arbitraryIx1 <*> arbitrary + +instance Arbitrary Ix5 where + arbitrary = (:>) <$> arbitraryIx1 <*> arbitrary + +instance CoArbitrary Ix2 where + coarbitrary (i :. j) = coarbitrary i . coarbitrary j + +instance CoArbitrary Ix3 where + coarbitrary (i :> ix) = coarbitrary i . coarbitrary ix + +instance CoArbitrary Ix4 where + coarbitrary (i :> ix) = coarbitrary i . coarbitrary ix + +instance CoArbitrary Ix5 where + coarbitrary (i :> ix) = coarbitrary i . coarbitrary ix + +instance Function Ix2 where + function = functionMap fromIx2 toIx2 + +instance Function Ix3 where + function = functionMap fromIx3 toIx3 + +instance Function Ix4 where + function = functionMap fromIx4 toIx4 + +instance Function Ix5 where + function = functionMap fromIx5 toIx5 + + +prop_IsSafeIndex :: Index ix => SzIx ix -> Bool +prop_IsSafeIndex (SzIx sz ix) = isSafeIndex sz ix + +prop_RepairSafeIx :: Index ix => SzIx ix -> Property +prop_RepairSafeIx (SzIx sz ix) = + ix === repairIndex sz ix (errorImpossible "below zero") (errorImpossible "above zero") + where + errorImpossible msg sz1 ix1 = + error $ "Impossible <" ++ msg ++ ">: " ++ show sz1 ++ " and " ++ show ix1 + +prop_UnconsCons :: Index ix => ix -> Property +prop_UnconsCons ix = ix === uncurry consDim (unconsDim ix) + +prop_UnsnocSnoc :: Index ix => ix -> Property +prop_UnsnocSnoc ix = ix === uncurry snocDim (unsnocDim ix) + +prop_ToFromLinearIndex :: Index ix => SzIx ix -> Property +prop_ToFromLinearIndex (SzIx sz ix) = + isSafeIndex sz ix ==> ix == fromLinearIndex sz (toLinearIndex sz ix) + +prop_FromToLinearIndex :: Index ix => SzNE ix -> NonNegative Int -> Property +prop_FromToLinearIndex (SzNE sz) (NonNegative i) = + totalElem sz >= i ==> i == toLinearIndex sz (fromLinearIndex sz i) + +prop_CountElements :: Index ix => Int -> Sz ix -> Property +prop_CountElements thresh sz = + totalElem sz < thresh ==> totalElem sz == + iter zeroIndex (unSz sz) (pureIndex 1) (<) 0 (const (+ 1)) + +prop_IterMonotonic :: Index ix => Int -> Sz ix -> Property +prop_IterMonotonic thresh sz = + totalElem sz < thresh ==> fst $ + iter (liftIndex succ zeroIndex) (unSz sz) (pureIndex 1) (<) (True, zeroIndex) mono + where + mono curIx (prevMono, prevIx) = + let isMono = prevMono && prevIx < curIx + in isMono `seq` (isMono, curIx) + +prop_IterMonotonicM :: Index ix => Int -> Sz ix -> Property +prop_IterMonotonicM thresh sz = + totalElem sz < thresh ==> fst $ + runIdentity $ iterM (liftIndex succ zeroIndex) (unSz sz) (pureIndex 1) (<) (True, zeroIndex) mono + where + mono curIx (prevMono, prevIx) = + let isMono = prevMono && prevIx < curIx + in return $ isMono `seq` (isMono, curIx) + + +prop_IterMonotonicBackwards :: Index ix => Int -> Sz ix -> Property +prop_IterMonotonicBackwards thresh sz@(Sz szix) = + totalElem sz < thresh ==> fst $ + iter (liftIndex pred szix) zeroIndex (pureIndex (-1)) (>=) (True, szix) mono + where + mono curIx (prevMono, prevIx) = + let isMono = prevMono && prevIx > curIx + in isMono `seq` (isMono, curIx) + +prop_IterMonotonicBackwardsM :: Index ix => Int -> Sz ix -> Property +prop_IterMonotonicBackwardsM thresh sz@(Sz szix) = + totalElem sz < thresh ==> fst $ + runIdentity $ iterM (liftIndex pred szix) zeroIndex (pureIndex (-1)) (>=) (True, szix) mono + where + mono curIx (prevMono, prevIx) = + let isMono = prevMono && prevIx > curIx + in return $ isMono `seq` (isMono, curIx) + +prop_LiftLift2 :: Index ix => ix -> Int -> Bool +prop_LiftLift2 ix delta = liftIndex2 (+) ix (liftIndex (+delta) zeroIndex) == + liftIndex (+delta) ix + + +prop_BorderRepairSafe :: Index ix => Border ix -> SzNE ix -> ix -> Property +prop_BorderRepairSafe border@(Fill defIx) (SzNE sz) ix = + not (isSafeIndex sz ix) ==> handleBorderIndex border sz id ix == defIx +prop_BorderRepairSafe border (SzNE sz) ix = + not (isSafeIndex sz ix) ==> isSafeIndex sz (handleBorderIndex border sz id ix) + + +prop_GetDropInsert :: Index ix => DimIx ix -> ix -> Property +prop_GetDropInsert (DimIx dim) ix = + property $ + flip shouldReturn ix $ do + i <- getDimM ix dim + ixL <- dropDimM ix dim + insertDimM ixL dim i + +prop_PullOutInsert :: Index ix => DimIx ix -> ix -> Property +prop_PullOutInsert (DimIx dim) ix = + property $ + flip shouldReturn ix $ do + (i, ixL) <- pullOutDimM ix dim + insertDimM ixL dim i + +prop_getDimException :: (Typeable ix, Index ix) => Dim -> ix -> Property +prop_getDimException d ix = + (d <= 0 || d > dimensions (Just ix)) ==> + assertExceptionIO (== IndexDimensionException ix d) (getDimM ix d) + +prop_setDimException :: (Typeable ix, Index ix) => Dim -> ix -> Int -> Property +prop_setDimException d ix i = + (d <= 0 || d > dimensions (Just ix)) ==> + assertExceptionIO (== IndexDimensionException ix d) (setDimM ix d i) + +prop_PullOutDimException :: (Typeable ix, Index ix) => Dim -> ix -> Property +prop_PullOutDimException d ix = + (d <= 0 || d > dimensions (Just ix)) ==> + assertExceptionIO (== IndexDimensionException ix d) (pullOutDimM ix d) + +prop_InsertDimException :: + forall ix. (Typeable (Lower ix), Index ix) + => Dim + -> Lower ix + -> Int + -> Property +prop_InsertDimException d ix i = + (d <= 0 || d > dimensions resIO) ==> assertExceptionIO (== IndexDimensionException ix d) resIO + where + resIO = insertDimM ix d i :: IO ix + + +prop_UnconsGetDrop :: (Index (Lower ix), Index ix) => ix -> Property +prop_UnconsGetDrop ix = + property $ + flip shouldReturn (unconsDim ix) $ do + i <- getDimM ix (dimensions (Just ix)) + ixL <- dropDimM ix (dimensions (Just ix)) + return (i, ixL) + +prop_UnsnocGetDrop :: (Index (Lower ix), Index ix) => ix -> Property +prop_UnsnocGetDrop ix = + property $ + flip shouldReturn (unsnocDim ix) $ do + i <- getDimM ix 1 + ixL <- dropDimM ix 1 + return (ixL, i) + +prop_SetAll :: Index ix => ix -> Property +prop_SetAll ix = property $ do + replaceDims dims `shouldReturn` ix + replaceDims (reverse dims) `shouldReturn` ix + where + replaceDims = foldM (\cix d -> getDimM ix d >>= setDimM cix d) zeroIndex + dims = [1 .. dimensions (Just ix)] :: [Dim] + + +prop_SetGet :: Index ix => ix -> DimIx ix -> Int -> Property +prop_SetGet ix (DimIx dim) n = n === getDim' (setDim' ix dim n) dim + + + +prop_BorderIx1 :: Positive Int -> Border Char -> Fun Ix1 Char -> SzNE Ix1 -> Ix1 -> Property +prop_BorderIx1 (Positive period) border getVal (SzNE sz) ix = + if isSafeIndex sz ix + then val === apply getVal ix + else case border of + Fill defVal -> val === defVal + Wrap -> + val === + handleBorderIndex + border + sz + (apply getVal) + (liftIndex2 (+) (liftIndex (* period) (unSz sz)) ix) + Edge -> + if ix < 0 + then val === apply getVal (liftIndex (max 0) ix) + else val === apply getVal (liftIndex2 min (liftIndex (subtract 1) (unSz sz)) ix) + Reflect -> + val === + handleBorderIndex + border + sz + (apply getVal) + (liftIndex2 (+) (liftIndex (* (2 * signum ix * period)) (unSz sz)) ix) + Continue -> + val === + handleBorderIndex + Reflect + sz + (apply getVal) + (if ix < 0 + then ix - 1 + else ix + 1) + where + val = handleBorderIndex border sz (apply getVal) ix + + +prop_BinaryNumIx :: + (Num ix, Index ix) => (forall n . Num n => n -> n -> n) -> ix -> ix -> Property +prop_BinaryNumIx f ix1 ix2 = zipWith f (ixToList ix1) (ixToList ix2) === ixToList (f ix1 ix2) + +prop_UnaryNumIx :: + (Num ix, Index ix) => (forall n . Num n => n -> n) -> ix -> Property +prop_UnaryNumIx f ix = map f (ixToList ix) === ixToList (f ix) + +prop_BinaryNumSz :: + (Num ix, Index ix) => (forall n . Num n => n -> n -> n) -> Sz ix -> Sz ix -> Property +prop_BinaryNumSz f sz1 sz2 = + zipWith f' (ixToList (unSz sz1)) (ixToList (unSz sz2)) === ixToList (unSz (f sz1 sz2)) + where + f' x y = max 0 (f x y) + +prop_UnaryNumSz :: + (Num ix, Index ix) => (forall n . Num n => n -> n) -> Sz ix -> Property +prop_UnaryNumSz f sz = map f' (ixToList (unSz sz)) === ixToList (unSz (f sz)) + where + f' = max 0 . f + + + +prop_IterLinearM :: Index ix => Sz ix -> NonNegative Int -> Positive Int -> Property +prop_IterLinearM sz (NonNegative start) (Positive increment) = property $ do + xs <- iterLinearM sz start (totalElem sz) increment (<) [] $ \i ix acc -> do + toLinearIndex sz ix `shouldBe` i + pure (i:acc) + reverse xs `shouldBe` [start, start + increment .. totalElem sz - 1] + +prop_IterLinearM_ :: Index ix => Sz ix -> NonNegative Int -> Positive Int -> Property +prop_IterLinearM_ sz (NonNegative start) (Positive increment) = property $ do + ref <- newIORef [] + iterLinearM_ sz start (totalElem sz) increment (<) $ \i ix -> do + toLinearIndex sz ix `shouldBe` i + modifyIORef' ref (i:) + xs <- readIORef ref + reverse xs `shouldBe` [start, start + increment .. totalElem sz - 1] + +----------- +-- Specs -- +----------- + +specIx1 :: Spec +specIx1 = describe "Ix1" $ do + ixSpec @Ix1 + ixNumSpec @Ix1 + it "Border" $ property prop_BorderIx1 + + +ixSpec :: + forall ix. (Typeable (Lower ix), Arbitrary (Lower ix), Typeable ix, Index ix, Arbitrary ix) + => Spec +ixSpec = do + let threshold = 50000 + describe "Safety" $ do + it "IsSafeIndex" $ property $ prop_IsSafeIndex @ix + it "RepairSafeIx" $ property $ prop_RepairSafeIx @ix + describe "Lifting" $ + it "Lift/Lift2" $ property $ prop_LiftLift2 @ix + describe "Linear" $ do + it "ToFromLinearIndex" $ property $ prop_ToFromLinearIndex @ix + it "FromToLinearIndex" $ property $ prop_FromToLinearIndex @ix + describe "Iterator" $ do + it "CountElements" $ property $ prop_CountElements @ix threshold + it "Monotonic" $ property $ prop_IterMonotonic @ix threshold + it "MonotonicBackwards" $ property $ prop_IterMonotonicBackwards @ix threshold + it "MonotonicM" $ property $ prop_IterMonotonicM @ix threshold + it "MonotonicBackwardsM" $ property $ prop_IterMonotonicBackwardsM @ix threshold + describe "Border" $ + it "BorderRepairSafe" $ property $ prop_BorderRepairSafe @ix + describe "SetGetDrop" $ do + it "SetAll" $ property $ prop_SetAll @ix + it "SetGet" $ property $ prop_SetGet @ix + it "GetDropInsert" $ property $ prop_GetDropInsert @ix + it "PullOutInsert" $ property $ prop_PullOutInsert @ix + it "UnconsCons" $ property $ prop_UnconsCons @ix + it "UnsnocSnoc" $ property $ prop_UnsnocSnoc @ix + describe "IndexDimensionException" $ do + it "getDimException" $ property $ prop_getDimException @ix + it "setDimException" $ property $ prop_setDimException @ix + it "PullOutDimException" $ property $ prop_PullOutDimException @ix + it "InsertDimException" $ property $ prop_InsertDimException @ix + describe "Dimension" $ do + it "GetInnerDimension" $ property $ \(ix :: ix) -> lastDim ix === getDimension ix Dim1 + it "GetOuterDimension" $ property $ + \(ix :: ix) -> headDim ix === getDimension ix (DimN :: Dimension (Dimensions ix)) + it "SetInnerDimension" $ property $ + \(ix :: ix) i -> snocDim (initDim ix) i === setDimension ix Dim1 i + it "SetOuterDimension" $ property $ + \(ix :: ix) i -> consDim i (tailDim ix) === setDimension ix (DimN :: Dimension (Dimensions ix)) i + it "DropInnerDimension" $ property $ \(ix :: ix) -> initDim ix === dropDimension ix Dim1 + it "DropOuterDimension" $ property $ + \(ix :: ix) -> tailDim ix === dropDimension ix (DimN :: Dimension (Dimensions ix)) + it "InsertInnerDimension" $ property $ + \(ixl :: Lower ix) i -> (snocDim ixl i :: ix) === insertDimension ixl Dim1 i + it "InsertOuterDimension" $ property $ + \(ixl :: Lower ix) i -> (consDim i ixl :: ix) === + insertDimension ixl (DimN :: Dimension (Dimensions ix)) i + it "PullOutInnerDimension" $ property $ + \(ix :: ix) -> unsnocDim ix === uncurry (flip (,)) (pullOutDimension ix Dim1) + it "PullInnerOuterDimension" $ property $ + \(ix :: ix) -> unconsDim ix === + pullOutDimension ix (DimN :: Dimension (Dimensions ix)) + + describe "NFData" $ do + it "rnf" $ property $ \ (ix :: ix) -> rnf ix `shouldBe` () + it "throws exception" $ property $ \ (DimIx d :: DimIx ix) (ix :: ix) -> + assertException (== ExpectedException) (setDim' ix d (throw ExpectedException)) + + +ix2UpSpec :: + forall ix. (Index ix, Index (Lower ix), Arbitrary ix, Arbitrary (Lower ix), Typeable (Lower ix)) + => Spec +ix2UpSpec = + describe "Higher/Lower" $ do + it "UnconsGetDrop" $ property $ prop_UnconsGetDrop @ix + it "UnsnocGetDrop" $ property $ prop_UnsnocGetDrop @ix + + +-- | Spec that validates the Num instance for any `Index ix => ix` +ixNumSpec :: forall ix . (Typeable ix, Num ix, Index ix, Arbitrary ix) => Spec +ixNumSpec = do + describe ("Num (" ++ showsType @ix ")") $ do + it "(+)" $ property $ prop_BinaryNumIx @ix (+) + it "(-)" $ property $ prop_BinaryNumIx @ix (-) + it "(*)" $ property $ prop_BinaryNumIx @ix (*) + it "negate" $ property $ prop_UnaryNumIx @ix negate + it "abs" $ property $ prop_UnaryNumIx @ix abs + it "signum" $ property $ prop_UnaryNumIx @ix signum + it "fromInteger" $ property $ \ (i :: Int) -> + (fromIntegral i :: ix) === liftIndex (const i) zeroIndex + describe "Constants" $ do + it "zeroIndex" $ (zeroIndex :: ix) `shouldBe` 0 + it "oneIndex" $ (oneIndex :: ix) `shouldBe` 1 + +-- | Spec that validates the Num instance for any `Index ix => Sz ix` +szNumSpec :: forall ix . (Typeable ix, Num ix, Index ix, Arbitrary ix) => Spec +szNumSpec = do + describe ("Num (" ++ showsType @(Sz ix) ")") $ do + it "(+)" $ property $ prop_BinaryNumSz @ix (+) + it "(-)" $ property $ prop_BinaryNumSz @ix (-) + it "(*)" $ property $ prop_BinaryNumSz @ix (*) + it "negate" $ property $ prop_UnaryNumSz @ix negate + it "abs" $ property $ prop_UnaryNumSz @ix abs + it "signum" $ property $ prop_UnaryNumSz @ix signum + it "fromInteger" $ property $ \ (i :: Int) -> + (fromIntegral i :: Sz ix) === SafeSz (pureIndex (max 0 i)) + it "fromIx" $ property $ \ (ix :: ix) -> unSz (Sz ix) === liftIndex (max 0) ix + describe "Constants" $ do + it "zeroSz" $ (zeroSz :: Sz ix) `shouldBe` 0 + it "oneSz" $ (oneSz :: Sz ix) `shouldBe` 1 + + +prop_PullOutInsertSize :: Index ix => DimIx ix -> Sz ix -> Property +prop_PullOutInsertSize (DimIx dim) sz = + either throw (sz ===) $ do + (i, szL) <- pullOutSzM sz dim + insertSzM szL dim i + + +szSpec :: + forall ix. (Index ix, Arbitrary ix) + => Spec +szSpec = do + describe "Higher/Lower" $ do + it "LiftSzNegate" $ property $ \ (sz :: Sz ix) -> liftSz negate sz === zeroSz + it "UnconsCons" $ property $ \ (sz :: Sz ix) -> sz === uncurry consSz (unconsSz sz) + it "UnsnocSnoc" $ property $ \ (sz :: Sz ix) -> sz === uncurry snocSz (unsnocSz sz) + it "PullOutInsert" $ property $ prop_PullOutInsertSize @ix + it "SetSzInnerSnoc" $ property $ + \ (sz :: Sz ix) i -> setSzM sz 1 i `shouldReturn` snocSz (fst $ unsnocSz sz) i + describe "Number of Elements" $ do + it "TotalElem" $ property $ + \(sz :: Sz ix) -> totalElem sz === foldlIndex (*) 1 (unSz sz) + it "IsNonEmpty" $ property $ + \(sz :: Sz ix) -> isNonEmpty sz === foldlIndex (\a x -> a && x > 0) True (unSz sz) + describe "Iterators" $ do + it "IterLinearM" $ property $ prop_IterLinearM @ix + it "IterLinearM_" $ property $ prop_IterLinearM_ @ix diff --git a/src/Test/Massiv/Core/Mutable.hs b/src/Test/Massiv/Core/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Core/Mutable.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Massiv.Core.Mutable + ( -- * Spec for Mutable instance + unsafeMutableSpec + , prop_UnsafeNewMsize + , prop_UnsafeThawFreeze + , prop_UnsafeInitializeNew + , prop_UnsafeArrayLinearCopy + -- ** Properties that aren't valid for boxed + , unsafeMutableUnboxedSpec + , prop_UnsafeInitialize + ) where + +import Data.Massiv.Array as A +import Data.Massiv.Array.Unsafe +import Test.Massiv.Core.Common +import Test.Massiv.Utils + + + +prop_UnsafeNewMsize :: + forall r ix e. + (Arbitrary ix, Mutable r ix e) + => Property +prop_UnsafeNewMsize = property $ \ sz -> do + marr :: MArray RealWorld r ix e <- unsafeNew sz + sz `shouldBe` msize marr + +prop_UnsafeNewLinearWriteRead :: + forall r ix e. + (Eq e, Show e, Mutable r ix e, Arbitrary ix, Arbitrary e) + => Property +prop_UnsafeNewLinearWriteRead = property $ \ (SzIx sz ix) e1 e2 -> do + marr :: MArray RealWorld r ix e <- unsafeNew sz + let i = toLinearIndex sz ix + unsafeLinearWrite marr i e1 + unsafeLinearRead marr i `shouldReturn` e1 + unsafeLinearModify marr (\ !_ -> pure e2) i `shouldReturn` e1 + unsafeLinearRead marr i `shouldReturn` e2 + + +prop_UnsafeThawFreeze :: + forall r ix e. + (Eq (Array r ix e), Show (Array r ix e), Mutable r ix e) + => Array r ix e -> Property +prop_UnsafeThawFreeze arr = arr === runST (unsafeFreeze (getComp arr) =<< unsafeThaw arr) + + +prop_UnsafeInitializeNew :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Show e + , Arbitrary e + , Arbitrary ix + , Mutable r ix e + ) + => Property +prop_UnsafeInitializeNew = + property $ \comp sz e -> + (A.replicate comp sz e :: Array r ix e) === + runST (unsafeFreeze comp =<< initializeNew (Just e) sz) + +prop_UnsafeInitialize :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Arbitrary ix + , Mutable r ix e + ) + => Property +prop_UnsafeInitialize = + property $ \comp sz -> + runST $ do + marr1 :: MArray s r ix e <- unsafeNew sz + initialize marr1 + marr2 :: MArray s r ix e <- initializeNew Nothing sz + (===) <$> unsafeFreeze comp marr1 <*> unsafeFreeze comp marr2 + + +prop_UnsafeLinearCopy :: + forall r ix e. (Eq (Array r ix e), Show (Array r ix e), Mutable r ix e) + => Array r ix e + -> Property +prop_UnsafeLinearCopy arr = + (arr, arr) === + runST + (do let sz = size arr + marrs <- thawS arr + marrd <- unsafeNew sz + unsafeLinearCopy marrs 0 marrd 0 (Sz (totalElem sz)) + arrd <- unsafeFreeze (getComp arr) marrd + arrs <- unsafeFreeze (getComp arr) marrs + pure (arrs, arrd)) + +prop_UnsafeLinearCopyPart :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Mutable r ix e + , Mutable r Ix1 e + , Extract r Ix1 e + , Resize r ix + ) + => ArrIx r ix e + -> NonNegative Ix1 + -> Ix1 + -> Property +prop_UnsafeLinearCopyPart (ArrIx arr ix) (NonNegative delta) toOffset = + arr === arrs .&&. extract' i k (flatten arr) === extract' j k arrd + where + sz = size arr + i = toLinearIndex sz ix + j = max 0 (i + toOffset) + k = Sz (totalElem sz - i - delta) + sz' = Sz (j + unSz k) + (arrs, arrd) = + runST $ do + marrs <- thawS arr -- make sure that the source does not get modified + marrd <- unsafeNew sz' + unsafeLinearCopy marrs i marrd j k + (,) <$> unsafeFreeze (getComp arr) marrs <*> unsafeFreeze (getComp arr) marrd + + +prop_UnsafeArrayLinearCopy :: + forall r ix e. (Eq (Array r ix e), Show (Array r ix e), Mutable r ix e) + => Array r ix e + -> Property +prop_UnsafeArrayLinearCopy arr = + arr === + runST + (do let sz = size arr + marr <- unsafeNew sz + unsafeArrayLinearCopy arr 0 marr 0 (Sz (totalElem sz)) + unsafeFreeze (getComp arr) marr) + + +prop_UnsafeArrayLinearCopyPart :: + forall r ix e. + ( Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Mutable r ix e + , Mutable r Ix1 e + , Extract r Ix1 e + , Resize r ix + ) + => ArrIx r ix e + -> NonNegative Ix1 + -> Ix1 + -> Property +prop_UnsafeArrayLinearCopyPart (ArrIx arr ix) (NonNegative delta) toOffset = + extract' i k (flatten arr) === extract' j k arr' + where + sz = size arr + i = toLinearIndex sz ix + j = max 0 (i + toOffset) + k = Sz (totalElem sz - i - delta) + sz' = Sz (j + unSz k) + arr' = + runST $ do + marr <- unsafeNew sz' + unsafeArrayLinearCopy arr i marr j k + unsafeFreeze (getComp arr) marr + +prop_UnsafeLinearSet :: + forall r ix e. + ( Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Mutable r ix e + , Extract r Ix1 e + , Resize r ix + ) + => Comp + -> SzIx ix + -> NonNegative Ix1 + -> e + -> Property +prop_UnsafeLinearSet comp (SzIx sz ix) (NonNegative delta) e = + extract' i k (flatten (A.replicate Seq sz e :: Array r ix e)) === + extract' i k (flatten (arrd :: Array r ix e)) + where + i = toLinearIndex sz ix + k = Sz (totalElem sz - i - delta) + arrd = + runST $ do + marrd <- unsafeNew sz + unsafeLinearSet marrd i k e + unsafeFreeze comp marrd + +prop_UnsafeLinearShrink :: + forall r ix e. + ( Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Mutable r ix e + , Extract r Ix1 e + , Resize r ix + ) + => ArrIx r ix e + -> Property +prop_UnsafeLinearShrink (ArrIx arr ix) = + extract' 0 k (flatten arr) === extract' 0 k (flatten arr') + where + sz = size arr + sz' = Sz (liftIndex2 (-) (unSz sz) ix) + k = Sz (totalElem sz') + arr' = + runST $ do + marr <- thawS arr + marr' <- unsafeLinearShrink marr sz' + unsafeFreeze (getComp arr) marr' + +prop_UnsafeLinearGrow :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Mutable r ix e + , Extract r Ix1 e + , Resize r ix + ) + => ArrIx r ix e + -> e + -> Property +prop_UnsafeLinearGrow (ArrIx arr ix) e = + extract' 0 k (flatten arr) === extract' 0 k (flatten arrGrown) .&&. + arrCopied === arrGrown + where + sz = size arr + sz' = Sz (liftIndex2 (+) (unSz sz) ix) + k = Sz (totalElem sz) + (arrCopied, arrGrown) = + runST $ do + marrCopied <- unsafeNew sz' + unsafeArrayLinearCopy arr 0 marrCopied 0 k + marr <- thawS arr + marrGrown <- unsafeLinearGrow marr sz' + when (sz' /= sz) $ do + unsafeLinearSet marrGrown (totalElem sz) (Sz (totalElem sz' - totalElem sz)) e + unsafeLinearSet marrCopied (totalElem sz) (Sz (totalElem sz' - totalElem sz)) e + (,) <$> unsafeFreeze (getComp arr) marrCopied <*> unsafeFreeze (getComp arr) marrGrown + + +unsafeMutableSpec :: + forall r ix e. + ( Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Eq (Array r ix e) + , Show (Array r ix e) + , Mutable r ix e + , Mutable r Ix1 e + , Show e + , Eq e + , Arbitrary e + , Arbitrary ix + , Typeable e + , Typeable ix + , Extract r Ix1 e + , Resize r ix + ) + => Spec +unsafeMutableSpec = + describe ("Mutable (" ++ showsArrayType @r @ix @e ") (Unsafe)") $ do + it "UnsafeNewMsize" $ prop_UnsafeNewMsize @r @ix @e + it "UnsafeNewLinearWriteRead" $ prop_UnsafeNewLinearWriteRead @r @ix @e + it "UnsafeThawFreeze" $ property $ prop_UnsafeThawFreeze @r @ix @e + it "UnsafeInitializeNew" $ prop_UnsafeInitializeNew @r @ix @e + it "UnsafeLinearSet" $ property $ prop_UnsafeLinearSet @r @ix @e + it "UnsafeLinearCopy" $ property $ prop_UnsafeLinearCopy @r @ix @e + it "UnsafeLinearCopyPart" $ property $ prop_UnsafeLinearCopyPart @r @ix @e + it "UnsafeArrayLinearCopy" $ property $ prop_UnsafeArrayLinearCopy @r @ix @e + it "UnsafeArrayLinearCopyPart" $ property $ prop_UnsafeArrayLinearCopyPart @r @ix @e + it "UnsafeLinearShrink" $ property $ prop_UnsafeLinearShrink @r @ix @e + it "UnsafeLinearGrow" $ property $ prop_UnsafeLinearGrow @r @ix @e + +unsafeMutableUnboxedSpec :: + forall r ix e. + (Typeable e, Typeable ix, Eq (Array r ix e), Show (Array r ix e), Arbitrary ix, Mutable r ix e) + => Spec +unsafeMutableUnboxedSpec = + describe ("Mutable Unboxed (" ++ showsArrayType @r @ix @e ") (Unsafe)") $ + it "UnsafeInitialize" $ prop_UnsafeInitialize @r @ix @e diff --git a/src/Test/Massiv/Utils.hs b/src/Test/Massiv/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/Massiv/Utils.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Massiv.Utils + ( showsType + , showsArrayType + , assertException + , assertExceptionIO + , assertSomeException + , assertSomeExceptionIO + , toStringException + , ExpectedException(..) + , applyFun2Compat + , module X + ) where + +import Control.Monad as X +import Control.Monad.ST as X +import Data.Maybe as X (fromMaybe, isJust, isNothing) +import Data.Typeable as X +import Test.QuickCheck as X hiding ((.&.)) +import Test.QuickCheck.Monadic as X +import Test.Hspec as X +import Test.QuickCheck.Function as X +import Control.DeepSeq (NFData, deepseq) +import UnliftIO.Exception (Exception(..), SomeException, catch, catchAny) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup as X ((<>)) +#endif + + +-- | Use Typeable to show the type. +showsType :: forall t . Typeable t => ShowS +showsType = showsTypeRep (typeRep (Proxy :: Proxy t)) + +-- | Use Typeable to show the array type +showsArrayType :: forall r ix e . (Typeable r, Typeable ix, Typeable e) => ShowS +showsArrayType = + ("Array " ++) . showsType @r . (" (" ++) . showsType @ix . (") " ++) . showsType @e + + +assertException :: + (Testable b, NFData a, Exception exc) + => (exc -> b) -- ^ Return True if that is the exception that was expected + -> a -- ^ Value that should throw an exception, when fully evaluated + -> Property +assertException isExc = assertExceptionIO isExc . pure + + +assertSomeException :: NFData a => a -> Property +assertSomeException = assertSomeExceptionIO . pure + + +assertExceptionIO :: + (Testable b, NFData a, Exception exc) + => (exc -> b) -- ^ Return True if that is the exception that was expected + -> IO a -- ^ IO Action that should throw an exception + -> Property +assertExceptionIO isExc action = + monadicIO $ + run $ + catch + (do res <- action + res `deepseq` return (counterexample "Did not receive an exception" False)) + (\exc -> displayException exc `deepseq` return (property (isExc exc))) + +assertSomeExceptionIO :: NFData a => IO a -> Property +assertSomeExceptionIO action = + monadicIO $ + run $ + catchAny + (do res <- action + res `deepseq` return (counterexample "Did not receive an exception" False)) + (\exc -> displayException exc `deepseq` return (property True)) + + +toStringException :: Either SomeException a -> Either String a +toStringException = either (Left . displayException) Right + + +data ExpectedException = ExpectedException deriving (Show, Eq) + +instance Exception ExpectedException + + +applyFun2Compat :: Fun (a, b) c -> (a -> b -> c) +#if MIN_VERSION_QuickCheck(2,10,0) +applyFun2Compat = applyFun2 +#else +applyFun2Compat (Fun _ f) a b = f (a, b) +instance Function Word where + function = functionMap fromIntegral fromInteger +#endif diff --git a/tests/Data/Massiv/Array/Delayed/InterleavedSpec.hs b/tests/Data/Massiv/Array/Delayed/InterleavedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Delayed/InterleavedSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +module Data.Massiv.Array.Delayed.InterleavedSpec + ( spec + ) where + +import Data.Massiv.Array +import Test.Massiv.Core + + +prop_EqDelayed :: + (Ragged L ix Int, Load D ix Int, Load DI ix Int) + => Array D ix Int + -> Property +prop_EqDelayed arr = computeAs P arr === computeAs P (toInterleaved arr) + + +prop_Resize :: + (Ragged L ix Int, Load D ix Int, Load DI ix Int) + => Array DI ix Int + -> Property +prop_Resize arr = + computeAs P (resize' k arr) === computeAs P (resize' k arrD) + where + arrD = fromInterleaved arr + k = Sz (totalElem (size arr)) + +spec :: Spec +spec = + describe "Interleaved same as Delayed" $ do + it "EqDelayed Ix1" $ property $ prop_EqDelayed @Ix1 + it "EqDelayed Ix2" $ property $ prop_EqDelayed @Ix2 + it "EqDelayed Ix3" $ property $ prop_EqDelayed @Ix3 + it "EqDelayed Ix4" $ property $ prop_EqDelayed @Ix4 + it "EqDelayed Ix5" $ property $ prop_EqDelayed @Ix5 + it "Resize Ix1" $ property $ prop_Resize @Ix1 + it "Resize Ix2" $ property $ prop_Resize @Ix2 + it "Resize Ix3" $ property $ prop_Resize @Ix3 + it "Resize Ix4" $ property $ prop_Resize @Ix4 + it "Resize Ix5" $ property $ prop_Resize @Ix5 diff --git a/tests/Data/Massiv/Array/Delayed/PushSpec.hs b/tests/Data/Massiv/Array/Delayed/PushSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Delayed/PushSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +module Data.Massiv.Array.Delayed.PushSpec (spec) where + +-- import Data.Massiv.Array.Delayed +-- import Data.Massiv.Array.Unsafe +-- import Data.Massiv.Array as A +import Test.Massiv.Core + + +-- prop_upsampleDifferentDefault :: +-- Proxy ix -> Comp -> SzIx ix -> Int -> Maybe Int -> Property +-- prop_upsampleDifferentDefault _ comp (SzIx sz ix) v mDef = +-- computeAs P (unsafeMakeLoadArray comp sz mDef $ \ put -> put ix v) + + +spec :: Spec +spec = pure () + -- describe "upsampleDifferentDefault" $ do + -- it "Ix1" $ property $ prop_upsampleDifferentDefault (Proxy :: Proxy Ix1) + -- it "Ix2" $ property $ prop_upsampleDifferentDefault (Proxy :: Proxy Ix2) + -- it "Ix3" $ property $ prop_upsampleDifferentDefault (Proxy :: Proxy Ix3) + -- it "Ix4" $ property $ prop_upsampleDifferentDefault (Proxy :: Proxy Ix4) + -- it "Ix5" $ property $ prop_upsampleDifferentDefault (Proxy :: Proxy Ix5) + + +-- identityDL :: Int -> Array DL Ix2 Int +-- identityDL n = makeLoadArrayS (Sz2 n n) 0 $ \ writeCell -> do +-- let f i = writeCell (i :. i) 1 +-- A.mapM_ f (0 ... n - 1) diff --git a/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs b/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Delayed/WindowedSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Massiv.Array.Delayed.WindowedSpec (spec) where + +import Data.Massiv.Array.Delayed +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array as A +import Test.Massiv.Core + + +data ArrDW ix e = ArrDW (Array D ix e) (Array DW ix e) + +instance (Show ix, Index ix, Show (Array D ix e), Show (Array DW ix e)) => Show (ArrDW ix e) where + show (ArrDW d dw) = + "Delayed:\n" ++ + show d ++ + "\nCorresponding Windowed:\n" ++ + --show dw ++ + windowInfo + where + windowInfo = + maybe + "\n No Window" + (\Window {windowStart, windowSize} -> + "\n With Window starting index (" ++ + show windowStart ++ ") and size (" ++ show windowSize ++ ")") $ + getWindow dw + +instance (Arbitrary ix, CoArbitrary ix, Index ix, Arbitrary e, Typeable e) => + Arbitrary (ArrDW ix e) where + arbitrary = do + ArrTiny (arr :: Array D ix e) <- arbitrary + let sz = size arr + ArrDW arr <$> + if totalElem sz == 0 + then return (makeArray (getComp arr) sz (unsafeIndex arr)) + else do + wix <- flip (liftIndex2 mod) (unSz sz) <$> arbitrary + wsz <- liftIndex (+1) . flip (liftIndex2 mod) (liftIndex2 (-) (unSz sz) wix) <$> arbitrary + return $ makeWindowedArray arr wix (Sz wsz) (unsafeIndex arr) + + +prop_EqDelayed :: + (Ragged L ix Int, Load DW ix Int) => Proxy ix -> ArrDW ix Int -> Property +prop_EqDelayed _ (ArrDW arrD arrDW) = + computeAs P arrD === computeAs P arrDW + +prop_EqDelayedStride :: + (Ragged L ix Int, StrideLoad DW ix Int) => Proxy ix -> Stride ix -> ArrDW ix Int -> Property +prop_EqDelayedStride _ stride (ArrDW arrD arrDW) = + computeWithStrideAs P stride arrD === computeWithStrideAs P stride arrDW + + +spec :: Spec +spec = do + describe "Equivalency with Delayed" $ do + it "Ix1" $ property $ prop_EqDelayed (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_EqDelayed (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_EqDelayed (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_EqDelayed (Proxy :: Proxy Ix4) + it "Ix5" $ property $ prop_EqDelayed (Proxy :: Proxy Ix5) + it "Ix2T" $ property $ prop_EqDelayed (Proxy :: Proxy Ix2T) + describe "Equivalency with Stride With Delayed" $ do + it "Ix1" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix4) + it "Ix5" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix5) + it "Ix2T" $ property $ prop_EqDelayedStride (Proxy :: Proxy Ix2T) diff --git a/tests/Data/Massiv/Array/DelayedSpec.hs b/tests/Data/Massiv/Array/DelayedSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/DelayedSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Data.Massiv.Array.DelayedSpec (spec) where + +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array as A +import Test.Massiv.Core + + +downsampleArr :: Source r ix e => Stride ix -> Array r ix e -> Array D ix e +downsampleArr stride arr = + unsafeBackpermute (strideSize stride (size arr)) (liftIndex2 (*) (unStride stride)) arr + +prop_computeWithStrideEqDownsample :: + Ragged L ix Int + => proxy ix + -> Stride ix + -> Array D ix Int + -> Property +prop_computeWithStrideEqDownsample _ stride arr = + computeWithStride stride arr === computeAs U (downsampleArr stride arr) + + +prop_computeWithStrideInterleavedEqDownsample :: + Ragged L ix Int + => proxy ix + -> Stride ix + -> Array D ix Int + -> Property +prop_computeWithStrideInterleavedEqDownsample _ stride arr = + computeWithStride stride (toInterleaved arr) === computeAs U (downsampleArr stride arr) + +prop_computeWithStrideWindowedEqDownsample :: + (Ragged L ix Int, StrideLoad DW ix Int) + => proxy ix + -> Stride ix + -> ArrIx D ix Int + -> Property +prop_computeWithStrideWindowedEqDownsample _ stride (ArrIx arr _) = + computeWithStride stride (insertWindow arr (Window zeroIndex (size arr) (unsafeIndex arr) Nothing)) === + -- Below triggers a bug in ghc-8.0 which results in a deadlock. + -- computeWithStride stride (makeWindowedArray arr zeroIndex (size arr) (unsafeIndex arr)) === + computeAs U (downsampleArr stride arr) + + +delayedSpec :: + (Arbitrary ix, StrideLoad DW ix Int, Ragged L ix Int) + => String + -> proxy ix + -> Spec +delayedSpec dimName proxy = + describe dimName $ do + it "computeWithStrideEqDownsample" $ property $ prop_computeWithStrideEqDownsample proxy + it "computeWithStrideInterleavedEqDownsample" $ + property $ prop_computeWithStrideInterleavedEqDownsample proxy + it "computeWithStrideWindowedEqDownsample" $ + property $ prop_computeWithStrideWindowedEqDownsample proxy + +spec :: Spec +spec = do + delayedSpec "Ix1" (Proxy :: Proxy Ix1) + delayedSpec "Ix2" (Proxy :: Proxy Ix2) + delayedSpec "Ix3" (Proxy :: Proxy Ix3) + delayedSpec "Ix4" (Proxy :: Proxy Ix4) diff --git a/tests/Data/Massiv/Array/Manifest/VectorSpec.hs b/tests/Data/Massiv/Array/Manifest/VectorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Manifest/VectorSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Massiv.Array.Manifest.VectorSpec (spec) where + +import Data.Massiv.Array.Manifest.Vector +import Data.Massiv.Array as A +import Test.Massiv.Core +import qualified Data.Vector as VB +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU + +prop_castToFromVector + :: ( VG.Vector (VRepr r) Int + , Mutable r ix Int + , Typeable (VRepr r) + , ARepr (VRepr r) ~ r + , Eq (Array r ix Int) + , Show (Array r ix Int) + ) + => proxy ix -> r -> ArrNE r ix Int -> Property +prop_castToFromVector _ _ (ArrNE arr) = + Just arr === (castToVector arr >>= castFromVector (getComp arr) (size arr)) + + +prop_toFromVector :: + forall r ix v. + ( Mutable r ix Int + , Mutable (ARepr v) ix Int + , VRepr (ARepr v) ~ v + , Eq (Array r ix Int) + , VG.Vector v Int + , Show (Array r ix Int) + , Typeable v + ) + => Proxy v + -> Proxy ix + -> r + -> ArrNE r ix Int + -> Property +prop_toFromVector _ _ _ (ArrNE arr) = + arr === fromVector' (getComp arr) (size arr) (toVector arr :: v Int) + + +toFromVectorSpec :: Spec +toFromVectorSpec = do + it_prop "Unboxed" U + it_prop "Primitive" P + it_prop "Storable" S + it_prop "BoxedStrict" B + where + it_prop name r = + describe name $ do + describe "CastToFrom" $ do + it "Ix1" $ property $ prop_castToFromVector (Proxy :: Proxy Ix1) r + it "Ix2" $ property $ prop_castToFromVector (Proxy :: Proxy Ix2) r + it "Ix3" $ property $ prop_castToFromVector (Proxy :: Proxy Ix3) r + describe "Through Boxed Vector" $ do + it "Ix1" $ property $ prop_toFromVector (Proxy :: Proxy VB.Vector) (Proxy :: Proxy Ix1) r + it "Ix2" $ property $ prop_toFromVector (Proxy :: Proxy VB.Vector) (Proxy :: Proxy Ix2) r + describe "Through Unboxed Vector" $ do + it "Ix1" $ property $ prop_toFromVector (Proxy :: Proxy VU.Vector) (Proxy :: Proxy Ix1) r + it "Ix2" $ property $ prop_toFromVector (Proxy :: Proxy VU.Vector) (Proxy :: Proxy Ix2) r + describe "Through Primitive Vector" $ do + it "Ix1" $ property $ prop_toFromVector (Proxy :: Proxy VP.Vector) (Proxy :: Proxy Ix1) r + it "Ix2" $ property $ prop_toFromVector (Proxy :: Proxy VP.Vector) (Proxy :: Proxy Ix2) r + describe "Through Storable Vector" $ do + it "Ix1" $ property $ prop_toFromVector (Proxy :: Proxy VS.Vector) (Proxy :: Proxy Ix1) r + it "Ix2" $ property $ prop_toFromVector (Proxy :: Proxy VS.Vector) (Proxy :: Proxy Ix2) r + + +spec :: Spec +spec = describe "toFromVector" toFromVectorSpec diff --git a/tests/Data/Massiv/Array/ManifestSpec.hs b/tests/Data/Massiv/Array/ManifestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/ManifestSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +module Data.Massiv.Array.ManifestSpec (spec) where + +import Data.ByteString as S +import Data.ByteString.Builder as S +import Data.ByteString.Lazy as SL +import Data.Massiv.Array as A +import Test.Massiv.Core +import Data.Word (Word8) + + +-- ByteString +prop_toFromByteString :: Manifest r Ix1 Word8 => Array r Ix1 Word8 -> Property +prop_toFromByteString arr = toManifest arr === fromByteString (getComp arr) (toByteString arr) + +prop_castToFromByteString :: Array S Ix1 Word8 -> Property +prop_castToFromByteString arr = arr === castFromByteString (getComp arr) (castToByteString arr) + + +prop_fromToByteString :: Comp -> [Word8] -> Property +prop_fromToByteString comp ls = bs === toByteString (fromByteString comp bs) + where bs = S.pack ls + +prop_toBuilder :: Array P Ix1 Word8 -> Property +prop_toBuilder arr = bs === SL.toStrict (S.toLazyByteString (toBuilder S.word8 arr)) + where bs = toByteString arr + +conversionSpec :: Spec +conversionSpec = + describe "ByteString" $ do + it "castTo/TromByteString" $ property prop_castToFromByteString + it "to/from ByteString P" $ property (prop_toFromByteString @P) + it "to/from ByteString S" $ property (prop_toFromByteString @S) + it "from/to ByteString" $ property prop_fromToByteString + it "toBuilder" $ property prop_toBuilder + + +spec :: Spec +spec = describe "Conversion" conversionSpec diff --git a/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs b/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs @@ -0,0 +1,37 @@ +module Data.Massiv.Array.Numeric.IntegralSpec + ( spec + ) where + +import Data.Massiv.Array as A +import Data.Massiv.Array.Numeric.Integral +import Test.Hspec + +gaussian :: Float -> Float +gaussian x = exp (x ^ (2 :: Int)) + +spec :: Spec +spec = do + let (a, b) = (0, 2) + integrator rule = rule Seq N (\ scale -> gaussian . scale) a b (Sz1 1) + describe "Integral Approximation" $ do + it "Midpoint Rule" $ do + integrator midpointRule 4 ! 0 `shouldBe` 14.485613 + integrator midpointRule 8 ! 0 `shouldBe` 15.905677 + integrator midpointRule 16 ! 0 `shouldBe` 16.311854 + integrator midpointRule 32 ! 0 `shouldBe` 16.417171 + integrator midpointRule 64 ! 0 `shouldBe` 16.443748 + integrator midpointRule 128 ! 0 `shouldBe` 16.450407 + it "Trapezoid Rule" $ do + integrator trapezoidRule 4 ! 0 `shouldBe` 20.644558 + integrator trapezoidRule 8 ! 0 `shouldBe` 17.565086 + integrator trapezoidRule 16 ! 0 `shouldBe` 16.735381 + integrator trapezoidRule 32 ! 0 `shouldBe` 16.523618 + integrator trapezoidRule 64 ! 0 `shouldBe` 16.470394 + integrator trapezoidRule 128 ! 0 `shouldBe` 16.457073 + it "Simspon's Rule" $ do + integrator simpsonsRule 4 ! 0 `shouldBe` 17.353626 + integrator simpsonsRule 8 ! 0 `shouldBe` 16.538595 + integrator simpsonsRule 16 ! 0 `shouldBe` 16.458815 + integrator simpsonsRule 32 ! 0 `shouldBe` 16.453030 + integrator simpsonsRule 64 ! 0 `shouldBe` 16.452653 + integrator simpsonsRule 128 ! 0 `shouldBe` 16.452629 diff --git a/tests/Data/Massiv/Array/Ops/ConstructSpec.hs b/tests/Data/Massiv/Array/Ops/ConstructSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/ConstructSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Massiv.Array.Ops.ConstructSpec (spec) where + +import Data.List as L +import Data.Massiv.Array as A +import Test.Massiv.Core +import qualified GHC.Exts as GHC (IsList(..)) +import Prelude as P + +prop_rangeEqRangeStep1 :: Int -> Int -> Property +prop_rangeEqRangeStep1 from to = range Seq from to === rangeStep' Par from 1 to + +prop_rangeEqEnumFromN :: Int -> Int -> Property +prop_rangeEqEnumFromN from to = range Seq from to === enumFromN Par from (Sz (to - from)) + +prop_rangeStepEqEnumFromStepN :: Int -> NonZero Int -> Int -> Property +prop_rangeStepEqEnumFromStepN from (NonZero step) sz = + rangeStep' Seq from step (from + step * sz) === enumFromStepN Par from step (Sz sz) + + +prop_rangeStepExc :: Int -> Int -> Property +prop_rangeStepExc from to = + assertException + (\case + IndexZeroException _ -> True + _ -> False) + (computeAs U (rangeStep' Seq from 0 to)) + +prop_toFromListIsList :: + (Show (Array U ix Int), GHC.IsList (Array U ix Int), Index ix) + => Proxy ix + -> ArrNE U ix Int + -> Property +prop_toFromListIsList _ (ArrNE arr) = arr === GHC.fromList (GHC.toList arr) + + +prop_toFromList :: + forall ix . (Show (Array U ix Int), Nested LN ix Int, Ragged L ix Int) + => Proxy ix + -> ArrNE U ix Int + -> Property +prop_toFromList _ (ArrNE arr) = comp === comp' .&&. arr === arr' + where comp = getComp arr + arr' = fromLists' comp (toLists arr) + comp' = getComp arr' + + +prop_excFromToListIx2 :: Comp -> [[Int]] -> Property +prop_excFromToListIx2 comp ls2 = + if P.null lsL || P.all (head lsL ==) lsL + then label "Expected Success" $ resultLs === ls2 + else label "Expected Failure" $ assertSomeException resultLs + where + lsL = P.map P.length ls2 + resultLs = toLists (fromLists' comp ls2 :: Array U Ix2 Int) + + +prop_excFromToListIx3 :: Comp -> [[[Int]]] -> Property +prop_excFromToListIx3 comp ls3 + | P.null (P.concat (P.concat ls3)) = + classify True "Expected Success" $ counterexample (show arr) $ totalElem (size arr) === 0 + | P.all (head lsL ==) lsL && P.all (P.all (head (head lsLL) ==)) lsLL = + classify True "Expected Success" $ counterexample (show arr) $ resultLs === ls3 + | otherwise = classify True "Expected Failure" $ assertSomeException resultLs + where + arr = fromLists' comp ls3 :: Array U Ix3 Int + resultLs = toLists arr + lsL = P.map P.length ls3 + lsLL = P.map (P.map P.length) ls3 + + +specConstructIx1 :: Spec +specConstructIx1 = do + it "toFromList" $ property (prop_toFromList (Proxy :: Proxy Ix1)) + it "toFromListIsList" $ property (prop_toFromListIsList (Proxy :: Proxy Ix1)) + it "rangeEqRangeStep1" $ property prop_rangeEqRangeStep1 + it "rangeEqEnumFromN" $ property prop_rangeEqEnumFromN + it "rangeStepEqEnumFromStepN" $ property prop_rangeStepEqEnumFromStepN + it "rangeStepExc" $ property prop_rangeStepExc + +specConstructIx2 :: Spec +specConstructIx2 = do + it "toFromList" $ property (prop_toFromList (Proxy :: Proxy Ix2)) + it "toFromListIsList" $ property (prop_toFromListIsList (Proxy :: Proxy Ix2)) + it "excFromToListIx2" $ property prop_excFromToListIx2 + +specConstructIx3 :: Spec +specConstructIx3 = do + it "toFromList" $ property (prop_toFromList (Proxy :: Proxy Ix3)) + it "toFromListIsList" $ property (prop_toFromListIsList (Proxy :: Proxy Ix3)) + it "excFromToListIx3" $ property prop_excFromToListIx3 + +mkIntermediate :: Int -> Array U Ix1 Int +mkIntermediate t = A.fromList Seq [t + 50, t + 75] + +initArr :: Array N Ix1 (Array U Ix1 Int) +initArr = makeArray Seq (Sz1 3) mkIntermediate + +initArr2 :: Array N Ix2 (Array U Ix1 Int) +initArr2 = makeArray Seq (Sz 2) (\ (x :. y) -> mkIntermediate (x+y)) + +prop_unfoldrList :: Sz1 -> Fun Word (Int, Word) -> Word -> Property +prop_unfoldrList sz1 f i = + conjoin $ + L.zipWith + (===) + (A.toList (computeAs P $ unfoldrS_ sz1 (apply f) i)) + (L.unfoldr (Just . apply f) i) + +specExpand :: Spec +specExpand = do + it "expandOuter" $ compute (expandOuter 2 A.index' initArr :: Array D Ix2 Int) `shouldBe` + resize' (Sz2 2 3) (fromList Seq [50, 51, 52, 75, 76, 77] :: Array U Ix1 Int) + it "expandInner" $ compute (expandInner 2 A.index' initArr :: Array D Ix2 Int) `shouldBe` + resize' (Sz2 3 2) (fromList Seq [50, 75, 51, 76, 52, 77] :: Array U Ix1 Int) + it "expandwithin" $ compute (expandWithin Dim1 2 A.index' initArr2 :: Array D Ix3 Int) `shouldBe` + resize' (Sz 2) (fromList Seq [50, 75, 51, 76, 51, 76, 52, 77] :: Array U Ix1 Int) + it "expandwithin'" $ compute (expandWithin' 1 2 A.index' initArr2 :: Array D Ix3 Int) `shouldBe` + resize' (Sz 2) (fromList Seq [50, 75, 51, 76, 51, 76, 52, 77] :: Array U Ix1 Int) + +spec :: Spec +spec = do + describe "Ix1" specConstructIx1 + describe "Ix2" specConstructIx2 + describe "Ix3" specConstructIx3 + describe "Expand" specExpand + describe "Unfolding" $ it "unfoldrS_" $ property prop_unfoldrList diff --git a/tests/Data/Massiv/Array/Ops/FoldSpec.hs b/tests/Data/Massiv/Array/Ops/FoldSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/FoldSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Data.Massiv.Array.Ops.FoldSpec (spec) where + +import qualified Data.Foldable as F +import Data.Massiv.Array as A +import Test.Massiv.Core +import Data.Semigroup +import Prelude hiding (map, product, sum) + + + +prop_SumSEqSumP :: Index ix => proxy ix -> Array D ix Int -> Bool +prop_SumSEqSumP _ arr = sum arr == sum (setComp Par arr) + + +prop_ProdSEqProdP :: Index ix => proxy ix -> Array D ix Int -> Bool +prop_ProdSEqProdP _ arr = product arr == product (setComp Par arr) + +prop_NestedFoldP :: Array D Ix1 (Array D Ix1 Int) -> Bool +prop_NestedFoldP arr = sum (setComp Par (map sum $ setComp Par arr)) == sum (map sum arr) + + +specFold :: + (Arbitrary ix, Index ix, Show (Array D ix Int)) + => proxy ix + -> String + -> Spec +specFold proxy dimStr = + describe dimStr $ do + it "sumS Eq sumP" $ property $ prop_SumSEqSumP proxy + it "prodS Eq prodP" $ property $ prop_ProdSEqProdP proxy + +foldOpsProp :: (Source P ix Int) => proxy ix -> Fun Int Bool -> ArrTinyNE P ix Int -> Property +foldOpsProp _ f (ArrTinyNE arr) = + (A.maximum' arr === getMax (foldMono Max arr)) .&&. + (A.minimum' arr === getMin (foldSemi Min maxBound arr)) .&&. + (A.sum arr === F.sum ls) .&&. + (A.product (A.map ((+ 0.1) . (fromIntegral :: Int -> Double)) arr) === + getProduct (foldMono (Product . (+ 0.1) . fromIntegral) arr)) .&&. + (A.all (apply f) arr === F.all (apply f) ls) .&&. + (A.any (apply f) arr === F.any (apply f) ls) .&&. + (A.or (A.map (apply f) arr) === F.or (fmap (apply f) ls)) .&&. + (A.and (A.map (apply f) arr) === F.and (fmap (apply f) ls)) + where + ls = toList arr + +spec :: Spec +spec = do + specFold (Nothing :: Maybe Ix1) "Ix1" + specFold (Nothing :: Maybe Ix2) "Ix2" + it "Nested Parallel Fold" $ property prop_NestedFoldP + describe "Foldable Props" $ do + it "Ix1" $ property $ foldOpsProp (Nothing :: Maybe Ix1) + it "Ix2" $ property $ foldOpsProp (Nothing :: Maybe Ix2) + it "Ix3" $ property $ foldOpsProp (Nothing :: Maybe Ix3) diff --git a/tests/Data/Massiv/Array/Ops/MapSpec.hs b/tests/Data/Massiv/Array/Ops/MapSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/MapSpec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Data.Massiv.Array.Ops.MapSpec (spec) where + +import Data.IORef +import Control.Monad.ST +import Data.Foldable as F +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array as A +import Test.Massiv.Core +import Prelude as P +import Control.Scheduler.Internal + +prop_zipUnzip :: + (Index ix, Show (Array D ix Int)) + => Array D ix Int + -> Array D ix Int + -> Property +prop_zipUnzip arr1 arr2 = + (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2) === A.unzip (A.zip arr1 arr2) + where sz = Sz (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) + +prop_zipFlip :: + (Index ix, Show (Array D ix (Int, Int))) + => Array D ix Int + -> Array D ix Int + -> Property +prop_zipFlip arr1 arr2 = + A.zip arr1 arr2 === + A.map (\(e2, e1) -> (e1, e2)) (A.zip arr2 arr1) + +prop_zipUnzip3 :: + (Index ix, Show (Array D ix Int)) + => Array D ix Int + -> Array D ix Int + -> Array D ix Int + -> Property +prop_zipUnzip3 arr1 arr2 arr3 = + (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2, extract' zeroIndex sz arr3) === + A.unzip3 (A.zip3 arr1 arr2 arr3) + where + sz = + Sz (liftIndex2 min (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) (unSz (size arr3))) + +prop_zipFlip3 :: + (Index ix, Show (Array D ix (Int, Int, Int))) + => Array D ix Int + -> Array D ix Int + -> Array D ix Int + -> Property +prop_zipFlip3 arr1 arr2 arr3 = + A.zip3 arr1 arr2 arr3 === A.map (\(e3, e2, e1) -> (e1, e2, e3)) (A.zip3 arr3 arr2 arr1) + + + +prop_itraverseA :: + (Index ix, Show (Array U ix Int)) => Array D ix Int -> Fun (ix, Int) Int -> Property +prop_itraverseA arr fun = + alt_imapM (\ix -> Just . applyFun2Compat fun ix) arr === + itraverseAR U (\ix -> Just . applyFun2Compat fun ix) arr + + +mapSpec :: + forall ix. + ( Arbitrary ix + , CoArbitrary ix + , Index ix + , Function ix + , Show (Array U ix Int) + , Show (Array D ix Int) + , Show (Array D ix (Int, Int)) + , Show (Array D ix (Int, Int, Int)) + ) + => Spec +mapSpec = do + describe "Zipping" $ do + it "zipUnzip" $ property $ prop_zipUnzip @ix + it "zipFlip" $ property $ prop_zipFlip @ix + it "zipUnzip3" $ property $ prop_zipUnzip3 @ix + it "zipFlip3" $ property $ prop_zipFlip3 @ix + describe "Traversing" $ do + it "itraverseA" $ property $ prop_itraverseA @ix + describe "StatefulMapping" $ do + it "mapWS" $ property $ prop_MapWS @ix + +spec :: Spec +spec = do + describe "Ix1" $ mapSpec @Ix1 + describe "Ix2" $ mapSpec @Ix2 + describe "Ix3" $ mapSpec @Ix3 + describe "Ix4" $ mapSpec @Ix4 + + + +alt_imapM + :: (Applicative f, Mutable r2 t1 b, Source r1 t1 t2) => + (t1 -> t2 -> f b) -> Array r1 t1 t2 -> f (Array r2 t1 b) +alt_imapM f arr = fmap loadList $ P.traverse (uncurry f) $ foldrS (:) [] (zipWithIndex arr) + where + loadList xs = + runST $ do + marr <- unsafeNew (size arr) + _ <- F.foldlM (\i e -> unsafeLinearWrite marr i e >> return (i + 1)) 0 xs + unsafeFreeze (getComp arr) marr + {-# INLINE loadList #-} + +zipWithIndex :: forall r ix e . Source r ix e => Array r ix e -> Array D ix (ix, e) +zipWithIndex arr = A.zip (range Seq zeroIndex (unSz (size arr))) arr +{-# INLINE zipWithIndex #-} + + +prop_MapWS :: (Show (Array U ix Int), Index ix) => Array U ix Int -> Property +prop_MapWS arr = + monadicIO $ + run $ do + states <- initWorkerStates (getComp arr) (\_ -> newIORef 0) + arr' <- + forWS states arr $ \e ref -> do + acc <- readIORef ref + writeIORef ref (acc + e) + pure e + accsArr <- A.mapM @P readIORef (evalArray Seq (_workerStatesArray states)) + pure (A.sum arr' === A.sum accsArr .&&. arr === arr') diff --git a/tests/Data/Massiv/Array/Ops/SliceSpec.hs b/tests/Data/Massiv/Array/Ops/SliceSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/SliceSpec.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Massiv.Array.Ops.SliceSpec (spec) where + +import Control.Applicative ((<|>)) +import Control.Exception +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array as A +import Test.Massiv.Core + +----------- +-- Size -- +----------- + +prop_ExtractEqualsExtractFromTo :: + ( Eq (Array (R r) ix e) + , Show (Array (R r) ix e) + , Extract r ix e + ) + => proxy (r, ix, e) + -> SzIx ix + -> Array r ix e + -> Property +prop_ExtractEqualsExtractFromTo _ (SzIx (Sz eIx) sIx) arr = + (extractFromToM sIx eIx arr <|> Nothing) === extractM sIx (Sz (liftIndex2 (-) eIx sIx)) arr + + +specSizeN :: + ( Eq (Array (R r) ix e) + , Show (Array (R r) ix e) + , Arbitrary (Array r ix e) + , Show (Array r ix e) + , Arbitrary ix + , Extract r ix e + ) + => proxy (r, ix, e) + -> Spec +specSizeN proxy = + describe "extract" $ + it "ExtractEqualsExtractFromTo" $ property $ prop_ExtractEqualsExtractFromTo proxy + + +----------- +-- Slice -- +----------- + + +prop_SliceRight :: + (Slice r ix e, OuterSlice r ix e, Eq (Elt r ix e), Show (Elt r ix e)) + => proxy (r, ix, e) + -> Int + -> Array r ix e + -> Property +prop_SliceRight _ i arr = + either (Left . displayException) Right (arr !?> i) === + either (Left . displayException) Right (arr (dimensions (size arr), i)) + + +prop_SliceLeft :: + (Slice r ix e, InnerSlice r ix e, Eq (Elt r ix e), Show (Elt r ix e)) + => proxy (r, ix, e) + -> Int + -> Array r ix e + -> Property +prop_SliceLeft _ i arr = + either (Left . displayException) Right (arr (1, i)) + + +prop_SliceIndexDim2D :: ArrIx D Ix2 Int -> Property +prop_SliceIndexDim2D (ArrIx arr ix@(i :. j)) = + val === evaluate' (arr i) j + where + val = unsafeIndex arr ix + + +prop_SliceIndexDim2RankD :: ArrIx D Ix2 Int -> Property +prop_SliceIndexDim2RankD (ArrIx arr ix@(i :. j)) = + val === evaluate' (arr (2, i)) j .&&. + val === evaluate' (arr (1, j)) i + where + val = unsafeIndex arr ix + + +prop_SliceIndexDim3D :: ArrIx D Ix3 Int -> Property +prop_SliceIndexDim3D (ArrIx arr ix@(i :> j :. k)) = + val === evaluate' (arr i !> j) k .&&. + val === evaluate' (arr i) j .&&. + val === evaluate' (arr !> i Property +prop_SliceIndexDim3RankD (ArrIx arr ix@(i :> j :. k)) = + val === evaluate' (arr (3, i) (2, j)) k .&&. + val === evaluate' (arr (3, i) (1, k)) j .&&. + val === evaluate' (arr (2, j) (2, i)) k .&&. + val === evaluate' (arr (2, j) (1, k)) i .&&. + val === evaluate' (arr (1, k) (2, i)) j .&&. + val === evaluate' (arr (1, k) (1, j)) i + where + val = unsafeIndex arr ix + + +prop_SliceIndexDim2M :: ArrIx P Ix2 Int -> Property +prop_SliceIndexDim2M (ArrIx arr' ix@(i :. j)) = + val === (arr !> i ! j) .&&. + val === (arr Property +prop_SliceIndexDim2RankM (ArrIx arr' ix@(i :. j)) = + val === (arr (2, i) ! j) .&&. + val === (arr (1, j) ! i) + where + arr = toManifest arr' + val = unsafeIndex arr ix + + +prop_SliceIndexDim3M :: ArrIx P Ix3 Int -> Property +prop_SliceIndexDim3M (ArrIx arr' ix@(i :> j :. k)) = + val === (arr i !> j ! k) .&&. + val === (arr i ! j) .&&. + val === (arr !> i Property +prop_SliceIndexDim3RankM (ArrIx arr' ix@(i :> j :. k)) = + val === (arr (3, i) (2, j) ! k) .&&. + val === (arr (3, i) (1, k) ! j) .&&. + val === (arr (2, j) (2, i) ! k) .&&. + val === (arr (2, j) (1, k) ! i) .&&. + val === (arr (1, k) (2, i) ! j) .&&. + val === (arr (1, k) (1, j) ! i) + where + arr = toManifest arr' + val = unsafeIndex arr ix + + +prop_SliceIndexDim4D :: ArrIx D Ix4 Int -> Property +prop_SliceIndexDim4D (ArrIx arr ix@(i1 :> i2 :> i3 :. i4)) = + val === evaluate' (arr !> i1 !> i2 !> i3) i4 .&&. + val === evaluate' (arr !> i1 !> i2 i1 i1 i2) i3 .&&. + val === evaluate' (arr i1 !> i2) i3 .&&. + val === evaluate' (arr i1 i1) i2 + where + val = unsafeIndex arr ix + +prop_SliceIndexDim4RankD :: ArrIx D Ix4 Int -> Property +prop_SliceIndexDim4RankD (ArrIx arr ix@(i1 :> i2 :> i3 :. i4)) = + val === unsafeIndex (arr (4, i1) (3, i2) (2, i3)) i4 .&&. + val === unsafeIndex (arr (4, i1) (2, i3) (3, i2) (3, i1)) (i3 :. i4) .&&. + val === unsafeIndex (arr (2, i3) (2, i2)) (i1 :. i4) .&&. + val === unsafeIndex (arr (2, i3) (1, i4) !> i1) i2 .&&. + val === unsafeIndex (arr (1, i4) !> i1 !> i2) i3 + where + val = evaluate' arr ix + + +prop_SliceIndexDim4RankM :: ArrIx P Ix4 Int -> Property +prop_SliceIndexDim4RankM (ArrIx arr' ix@(i1 :> i2 :> i3 :. i4)) = + val === (arr (4, i1) (3, i2) (2, i3) ! i4) .&&. + val === (arr (4, i1) (2, i3) (3, i2) (3, i1) ! (i3 :. i4)) .&&. + val === (arr (2, i3) (2, i2) ! (i1 :. i4)) .&&. + val === (arr (2, i3) (1, i4) !> i1 ! i2) .&&. + val === (arr (1, i4) !> i1 !> i2 ! i3) + where + arr = toManifest arr' + val = unsafeIndex arr ix + + +prop_SliceIndexDim4M :: ArrIx P Ix4 Int -> Property +prop_SliceIndexDim4M (ArrIx arr' ix@(i1 :> i2 :> i3 :. i4)) = + val === (arr !> i1 !> i2 !> i3 ! i4) .&&. + val === (arr !> i1 !> i2 i1 i1 i2 ! i3) .&&. + val === (arr i1 !> i2 ! i3) .&&. + val === (arr i1 i1 ! i2) + where + arr = toManifest arr' + val = unsafeIndex arr ix + + + +specSliceN :: ( Arbitrary (Array r ix e) + , Show (Array r ix e) + , Slice r ix e + , OuterSlice r ix e + , InnerSlice r ix e + , Eq (Elt r ix e) + , Show (Elt r ix e) + ) + => proxy (r, ix, e) -> Spec +specSliceN proxy = + describe "Slice" $ do + it "SliceRight" $ property $ prop_SliceRight proxy + it "SliceLeft" $ property $ prop_SliceLeft proxy + + + +spec :: Spec +spec = do + describe "Ix1" $ + specSizeN (Nothing :: Maybe (D, Ix1, Int)) + describe "Ix2" $ do + specSizeN (Nothing :: Maybe (D, Ix2, Int)) + specSliceN (Nothing :: Maybe (D, Ix2, Int)) + describe "SliceIndex" $ do + it "Delayed" $ property prop_SliceIndexDim2D + it "Rank - Delayed" $ property prop_SliceIndexDim2RankD + it "Manifest" $ property prop_SliceIndexDim2M + it "Rank - Manifest" $ property prop_SliceIndexDim2RankM + describe "Ix3" $ do + specSizeN (Nothing :: Maybe (D, Ix3, Int)) + specSliceN (Nothing :: Maybe (D, Ix3, Int)) + describe "SliceIndex" $ do + it "Delayed" $ property prop_SliceIndexDim3D + it "Rank - Delayed" $ property prop_SliceIndexDim3RankD + it "Manifest" $ property prop_SliceIndexDim3M + it "Rank - Manifest" $ property prop_SliceIndexDim3RankM + describe "Ix4" $ do + specSizeN (Nothing :: Maybe (D, Ix4, Int)) + specSliceN (Nothing :: Maybe (D, Ix4, Int)) + describe "SliceIndex" $ do + it "Delayed" $ property prop_SliceIndexDim4D + it "Rank - Delayed" $ property prop_SliceIndexDim4RankD + it "Manifest" $ property prop_SliceIndexDim4M + it "Rank - Manifest" $ property prop_SliceIndexDim4RankM diff --git a/tests/Data/Massiv/Array/Ops/SortSpec.hs b/tests/Data/Massiv/Array/Ops/SortSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/SortSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +module Data.Massiv.Array.Ops.SortSpec (spec) where + +import Data.List as L +import Data.Massiv.Array as A +import Test.Massiv.Core + + +prop_IsSorted :: (b -> b) -> ([Int] -> b) -> (b -> [Int]) -> [Int] -> Property +prop_IsSorted sortWith from to xs = + to (sortWith (from xs)) === sort xs + +spec :: Spec +spec = + describe "QuickSort" $ do + it "Seq" $ property $ prop_IsSorted (quicksort @P) (A.fromList Seq) A.toList + it "Par" $ property $ prop_IsSorted (quicksort @P) (A.fromList (ParN 4)) A.toList diff --git a/tests/Data/Massiv/Array/Ops/TransformSpec.hs b/tests/Data/Massiv/Array/Ops/TransformSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/Ops/TransformSpec.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +module Data.Massiv.Array.Ops.TransformSpec (spec) where + +import Data.Massiv.Array as A +import Test.Massiv.Core +import Data.Sequence as S +import Prelude as P +import Data.Foldable as F (foldl', toList) +import Data.Maybe + +prop_transposeOuterInner :: Array D Ix2 Int -> Property +prop_transposeOuterInner arr = transposeOuter arr === transpose arr + +prop_upsampleDownsample :: + (Show (Array P ix Int), Index ix) => ArrTiny P ix Int -> Stride ix -> Int -> Property +prop_upsampleDownsample (ArrTiny arr) stride fill = + arr === compute (downsample stride (computeAs P (upsample fill stride arr))) + +prop_ExtractAppend + :: (Show (Array P ix Int), Index ix) + => DimIx ix -> ArrIx P ix Int -> Property +prop_ExtractAppend (DimIx dim) (ArrIx arr ix) = + arr === compute (uncurry (append' dim) $ A.splitAt' dim (getDim' ix dim) arr) + +prop_SplitExtract + :: (Show (Array P ix Int), Show (Array M ix Int), Index ix) + => DimIx ix -> ArrIx P ix Int -> Positive Int -> Property +prop_SplitExtract (DimIx dim) (ArrIx arr ix) (Positive n) = + (computeAs P <$> splitAt' dim i arr) === (left, computeAs P (append' dim center right)) .&&. + (computeAs P splitLeft, splitRight) === (computeAs P (append' dim left center), right) + where i = getDim' ix dim + k = getDim' (unSz (size arr)) dim + n' = n `mod` (k - i) + (left, center, right) = either throw id (splitExtractM dim i (Sz n') arr) + (splitLeft, splitRight) = splitAt' dim (i + n') arr + +prop_ConcatAppend + :: (Show (Array P ix Int), Index ix) + => DimIx ix -> Comp -> Sz ix -> NonEmptyList (Fun ix Int) -> Property +prop_ConcatAppend (DimIx dim) comp sz (NonEmpty fns) = + foldl1 (\arr -> computeAs P . append' dim arr) arrs === + computeAs P (concat' dim arrs) + where + arrs = P.map (makeArrayR P comp sz . apply) fns + +prop_AppendMappend + :: Array D Ix1 Int -> Array D Ix1 Int -> Property +prop_AppendMappend arr1 arr2 = + computeAs P (append' 1 arr1 arr2) === computeAs P (toLoadArray arr1 <> toLoadArray arr2) + +prop_ConcatMconcat + :: [Array D Ix1 Int] -> Property +prop_ConcatMconcat arrs = + computeAs P (concat' 1 (A.empty : arrs)) === computeAs P (mconcat (fmap toLoadArray arrs)) + +prop_ExtractSizeMismatch :: + Index ix => ArrTiny P ix Int -> Positive Int -> Property +prop_ExtractSizeMismatch (ArrTiny arr) (Positive n) = + assertExceptionIO (SizeElementsMismatchException sz sz' ==) $ resizeM sz' arr + where + sz = size arr + sz' = Sz (totalElem sz + n) + +spec :: Spec +spec = do + it "transposeOuterInner" $ property prop_transposeOuterInner + describe "upsampleDownsample" $ do + it "Ix1" $ property (prop_upsampleDownsample @Ix1) + it "Ix2" $ property (prop_upsampleDownsample @Ix2) + it "Ix3" $ property (prop_upsampleDownsample @Ix3) + it "Ix4" $ property (prop_upsampleDownsample @Ix4) + describe "extractSizeMismatch" $ do + it "Ix1" $ property (prop_ExtractSizeMismatch @Ix1) + it "Ix2" $ property (prop_ExtractSizeMismatch @Ix2) + it "Ix3" $ property (prop_ExtractSizeMismatch @Ix3) + it "Ix4" $ property (prop_ExtractSizeMismatch @Ix4) + describe "ExtractAppend" $ do + it "Ix1" $ property (prop_ExtractAppend @Ix1) + it "Ix2" $ property (prop_ExtractAppend @Ix2) + it "Ix3" $ property (prop_ExtractAppend @Ix3) + it "Ix4" $ property (prop_ExtractAppend @Ix4) + describe "ExtractAppend" $ do + it "Ix1" $ property (prop_SplitExtract @Ix1) + it "Ix2" $ property (prop_SplitExtract @Ix2) + it "Ix3" $ property (prop_SplitExtract @Ix3) + it "Ix4" $ property (prop_SplitExtract @Ix4) + describe "ConcatAppend" $ do + it "Ix1" $ property (prop_ConcatAppend @Ix1) + it "Ix2" $ property (prop_ConcatAppend @Ix2) + it "Ix3" $ property (prop_ConcatAppend @Ix3) + it "Ix4" $ property (prop_ConcatAppend @Ix4) + describe "Monoid" $ do + it "Ix1" $ property prop_AppendMappend + it "Ix1" $ property prop_ConcatMconcat + describe "Sequence" $ do + it "ConsSnoc" $ property prop_ConsSnoc + it "UnconsUnsnoc" $ property prop_UnconsUnsnoc + describe "zoomWithGrid" $ do + it "Ix1" $ property (prop_zoomWithGridStrideCompute @Ix1) + it "Ix2" $ property (prop_zoomWithGridStrideCompute @Ix2) + it "Ix3" $ property (prop_zoomWithGridStrideCompute @Ix3) + it "Ix4" $ property (prop_zoomWithGridStrideCompute @Ix4) + +prop_zoomWithGridStrideCompute :: (Show (Array P ix Int), Index ix) => Array D ix Int -> Stride ix -> Int -> Property +prop_zoomWithGridStrideCompute arr stride defVal = + (computeWithStrideAs P stride' arr' === + A.replicate Seq (Sz (liftIndex (+ 1) $ unSz (size arr))) defVal) .&&. + (computeWithStrideAs P stride' (extract' (pureIndex 1) sz' arr') === compute arr) + where + arr' = computeAs P (zoomWithGrid defVal stride arr) + sz' = Sz (liftIndex (subtract 1) $ unSz (size arr')) + stride' = Stride (liftIndex (+ 1) $ unStride stride) + + +prop_UnconsUnsnoc :: Array D Ix1 Int -> Bool -> Property +prop_UnconsUnsnoc arr unconsFirst = + preJust $ do + (arr', u, s) <- + if unconsFirst + then do + (u, au) <- unconsM arr + (as, s) <- unsnocM au + pure (as, u, s) + else do + (as, s) <- unsnocM arr + (u, au) <- unconsM as + pure (au, u, s) + pure (computeAs U (A.snoc (A.cons u (toLoadArray (computeAs U arr'))) s) === compute arr) + +preJust :: Testable prop => Maybe prop -> Property +preJust m = isJust m ==> fromJust m + +prop_ConsSnoc :: Array D Ix1 Int -> [SeqOp Int] -> Property +prop_ConsSnoc arr ops = + A.toList (computeAs U (foldl' applyArraySeqOp (toLoadArray arr) ops)) === + F.toList (foldl' applySequenceSeqOp (S.fromList (A.toList arr)) ops) + +data SeqOp e = Cons e | Snoc e deriving (Eq, Show) + +instance Arbitrary e => Arbitrary (SeqOp e) where + arbitrary = do + e <- arbitrary + elements [Cons e, Snoc e] + +applyArraySeqOp :: Array DL Ix1 e -> SeqOp e -> Array DL Ix1 e +applyArraySeqOp arr = \case + Cons x -> A.cons x arr + Snoc x -> A.snoc arr x + + +applySequenceSeqOp :: Seq a -> SeqOp a -> Seq a +applySequenceSeqOp arr = \case + Cons x -> x <| arr + Snoc x -> arr |> x diff --git a/tests/Data/Massiv/Array/StencilSpec.hs b/tests/Data/Massiv/Array/StencilSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/StencilSpec.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Massiv.Array.StencilSpec (spec) where + +import Control.DeepSeq (deepseq) +import Data.Default (Default(def)) +import Data.Massiv.Array as A +import Test.Massiv.Core + +-- sum3x3Stencil :: Fractional a => Stencil Ix2 a a +-- sum3x3Stencil = makeConvolutionStencil (3 :. 3) (1 :. 1) $ \ get -> +-- get (-1 :. -1) 1 . get (-1 :. 0) 1 . get (-1 :. 1) 1 . +-- get ( 0 :. -1) 1 . get ( 0 :. 0) 1 . get ( 0 :. 1) 1 . +-- get ( 1 :. -1) 1 . get ( 1 :. 0) 1 . get ( 1 :. 1) 1 +-- {-# INLINE sum3x3Stencil #-} + + +singletonStencil :: (Index ix) => (Int -> Int) -> Stencil ix Int Int +singletonStencil f = + makeStencil oneSz zeroIndex $ \ get -> fmap f (get zeroIndex) +{-# INLINE singletonStencil #-} + + +prop_MapSingletonStencil :: (Load DW ix Int, Manifest U ix Int) => + Proxy ix -> Fun Int Int -> Border Int -> ArrNE U ix Int -> Bool +prop_MapSingletonStencil _ f b (ArrNE arr) = + computeAs U (mapStencil b (singletonStencil (apply f)) arr) == computeAs U (A.map (apply f) arr) + +prop_MapSingletonStencilWithStride :: (StrideLoad DW ix Int, Manifest U ix Int) => + Proxy ix -> Fun Int Int -> Border Int -> ArrNE U ix Int -> Bool +prop_MapSingletonStencilWithStride _ f b (ArrNE arr) = + computeWithStride oneStride (mapStencil b (singletonStencil (apply f)) arr) == + computeAs U (A.map (apply f) arr) + +-- Tests out of bounds stencil indexing +prop_DangerousStencil :: + Index ix => Proxy ix -> NonZero Int -> DimIx ix -> SzIx ix -> Property +prop_DangerousStencil _ (NonZero s) (DimIx r) (SzIx sz ix) = + ix' `deepseq` assertSomeException $ makeStencil sz ix $ \get -> get ix' :: Value Int + where + ix' = liftIndex (* signum s) (setDim' zeroIndex r (getDim' (unSz sz) r)) + + +stencilSpec :: Spec +stencilSpec = do + describe "MapSingletonStencil" $ do + it "Ix1" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix4) + it "Ix2T" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2T) + describe "MapSingletonStencilWithStride" $ do + it "Ix1" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix3) + describe "DangerousStencil" $ do + it "Ix1" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix4) + + +stencilDirection :: (Default a, Unbox a, Manifest r Ix2 a) => Ix2 -> Array r Ix2 a -> Array U Ix2 a +stencilDirection ix = + computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) (1 :. 1) $ \f -> f ix) + + +stencilCorners :: + (Default a, Unbox a, Manifest r Ix2 a) => Ix2 -> Ix2 -> Array r Ix2 a -> Array U Ix2 a +stencilCorners ixC ix = computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) ixC $ \f -> f ix) + + +stencilConvolution :: Spec +stencilConvolution = do + let xs3 :: Array U Ix1 Int + xs3 = [1, 2, 3] + xs3f f = f (-1) 1 . f 0 2 . f 1 3 + xs4 :: Array U Ix1 Int + xs4 = [1, 2, 3, 4] + xs4f f = f (-2) 1 . f (-1) 2 . f 0 3 . f 1 4 + ys :: Array U Ix1 Int + ys = [1, 2, 3, 4, 5] + ysConvXs3 = [4, 10, 16, 22, 22] + ysConvXs4 = [10, 20, 30, 34, 31] + ysCorrXs3 = [8, 14, 20, 26, 14] + ysCorrXs4 = [11, 20, 30, 40, 26] + ysConvXs4' = [4, 10, 20, 30, 34] + ysCorrXs4' = [20, 30, 40, 26, 14] + xs4f' f = f (-1) 1 . f 0 2 . f 1 3 . f 2 4 + applyStencil s = computeAs U . mapStencil (Fill 0) s + describe "makeConvolutionStencilFromKernel" $ do + it "1x3" $ applyStencil (makeConvolutionStencilFromKernel xs3) ys `shouldBe` ysConvXs3 + it "1x4" $ applyStencil (makeConvolutionStencilFromKernel xs4) ys `shouldBe` ysConvXs4 + describe "makeCorrelationStencilFromKernel" $ do + it "1x3" $ applyStencil (makeCorrelationStencilFromKernel xs3) ys `shouldBe` ysCorrXs3 + it "1x4" $ applyStencil (makeCorrelationStencilFromKernel xs4) ys `shouldBe` ysCorrXs4 + describe "makeConvolutionStencil" $ do + it "1x3" $ applyStencil (makeConvolutionStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysConvXs3 + it "1x4" $ applyStencil (makeConvolutionStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysConvXs4 + it "1x4" $ applyStencil (makeConvolutionStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysConvXs4' + describe "makeCorrelationStencil" $ do + it "1x3" $ applyStencil (makeCorrelationStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysCorrXs3 + it "1x4" $ applyStencil (makeCorrelationStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysCorrXs4 + it "1x4" $ applyStencil (makeCorrelationStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysCorrXs4' + describe "makeConvolutionStencil == makeConvolutionStencilFromKernel" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + applyStencil (makeConvolutionStencil (Sz 3) 1 sobelX) arr === + applyStencil (makeConvolutionStencilFromKernel sobelKernelX) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + applyStencil (makeConvolutionStencil (Sz1 3) 1 xs3f) arr === + applyStencil (makeConvolutionStencilFromKernel xs3) arr + it "1x4" $ + property $ \(arr :: Array U Ix1 Int) -> + applyStencil (makeConvolutionStencil (Sz1 4) 2 xs4f) arr === + applyStencil (makeConvolutionStencilFromKernel xs4) arr + describe "makeCorrelationStencil == makeCorrelationStencilFromKernel" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + applyStencil (makeCorrelationStencil (Sz 3) 1 sobelX) arr === + applyStencil (makeCorrelationStencilFromKernel sobelKernelX) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + applyStencil (makeCorrelationStencil (Sz1 3) 1 xs3f) arr === + applyStencil (makeCorrelationStencilFromKernel xs3) arr + it "1x4" $ + property $ \(arr :: Array U Ix1 Int) -> + applyStencil (makeCorrelationStencil (Sz1 4) 2 xs4f) arr === + applyStencil (makeCorrelationStencilFromKernel xs4) arr + describe "makeConvolutionStencil == makeCorrelationStencil . rotate180" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + applyStencil (makeConvolutionStencilFromKernel sobelKernelX) arr === + applyStencil (makeCorrelationStencilFromKernel (rotate180 sobelKernelX)) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + applyStencil (makeConvolutionStencilFromKernel xs3) arr === + applyStencil (makeCorrelationStencilFromKernel (rotate180 xs3)) arr + -- it "1x4" $ + -- property $ \(arr :: Array U Ix1 Int) -> + -- applyStencil (makeConvolutionStencilFromKernel xs4) arr === + -- applyStencil (makeCorrelationStencilFromKernel (rotate180 xs4)) arr + +spec :: Spec +spec = do + describe "Stencil" $ do + stencilSpec + let arr = [[1, 2, 3], [4, 5, 6], [7, 8, 9]] :: Array U Ix2 Int + describe "Unit tests Ix2" $ do + it "Direction Left" $ + stencilDirection (0 :. 1) arr `shouldBe` [[2, 3, 0], [5, 6, 0], [8, 9, 0]] + it "Direction Right" $ + stencilDirection (0 :. -1) arr `shouldBe` [[0, 1, 2], [0, 4, 5], [0, 7, 8]] + it "Direction Down" $ + stencilDirection (1 :. 0) arr `shouldBe` [[4, 5, 6], [7, 8, 9], [0, 0, 0]] + it "Direction Up" $ + stencilDirection (-1 :. 0) arr `shouldBe` [[0, 0, 0], [1, 2, 3], [4, 5, 6]] + it "Direction Left/Top Corner" $ + stencilCorners (0 :. 0) (2 :. 2) arr `shouldBe` [[9, 0, 0], [0, 0, 0], [0, 0, 0]] + it "Direction Right/Top Corner" $ + stencilCorners (0 :. 2) (2 :. -2) arr `shouldBe` [[0, 0, 7], [0, 0, 0], [0, 0, 0]] + it "Direction Right/Bottom Corner" $ + stencilCorners (2 :. 2) (-2 :. -2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [0, 0, 1]] + it "Direction Left/Bottom Corner" $ + stencilCorners (2 :. 0) (-2 :. 2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [3, 0, 0]] + describe "mapStencil with stride" $ do + let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int + stencil = makeConvolutionStencilFromKernel kernel + stride = Stride 2 + it "map stencil with stride on small array" $ + let strideArr = mapStencil (Fill 0) stencil arr + in computeWithStrideAs U stride strideArr `shouldBe` [[-4, 8], [2, 14]] + it "map stencil with stride on larger array" $ + let largeArr = makeArrayR U Seq (Sz 5) (succ . toLinearIndex (Sz 5)) + strideArr = mapStencil (Fill 0) stencil largeArr + in computeWithStrideAs U stride strideArr `shouldBe` + [[-6, 1, 14], [-13, 9, 43], [4, 21, 44]] + stencilConvolution + +sobelX :: Num e => (Ix2 -> e -> e -> e) -> e -> e +sobelX f = f (-1 :. -1) (-1) . f (-1 :. 1) 1 . + f ( 0 :. -1) (-2) . f ( 0 :. 1) 2 . + f ( 1 :. -1) (-1) . f ( 1 :. 1) 1 + +sobelKernelX :: Array U Ix2 Int +sobelKernelX = [ [-1, 0, 1] + , [-2, 0, 2] + , [-1, 0, 1] ] + +rotate180 :: (Num ix, Index ix) => Array U ix Int -> Array U ix Int +rotate180 = computeAs U . transform' (\sz -> (sz, sz)) (\(Sz sz) f ix -> f (sz - 1 - ix)) diff --git a/tests/Data/Massiv/ArraySpec.hs b/tests/Data/Massiv/ArraySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/ArraySpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- Here are contained tests for all instances for all main classes +module Data.Massiv.ArraySpec + ( spec + ) where + +import Data.Massiv.Array +import Test.Massiv.Core + + +prop_Construct_makeArray_Manifest :: + forall r ix. (Load D ix Int, Ragged L ix Int, Source r ix Int, Construct r ix Int) + => Comp + -> Sz ix + -> Fun Int Int + -> Property +prop_Construct_makeArray_Manifest comp sz f = + makeArrayLinearR D comp sz (apply f) === + delay (setComp Seq (makeArray comp sz (apply f . toLinearIndex sz) :: Array r ix Int)) + +prop_Construct_makeArray_Delayed :: + forall r ix. (Load D ix Int, Ragged L ix Int, Load r ix Int, Construct r ix Int) + => Comp + -> Sz ix + -> Fun Int Int + -> Property +prop_Construct_makeArray_Delayed comp sz f = + makeArrayLinearR P comp sz (apply f) === + compute (setComp Seq (makeArrayLinear comp sz (apply f)) :: Array r ix Int) + +prop_Functor :: + forall r ix. + (Load D ix Int, Ragged L ix Int, Load r ix Int, Construct r ix Int, Functor (Array r ix)) + => Comp + -> Sz ix + -> Fun Int Int + -> Fun Int Int + -> Property +prop_Functor comp sz f g = + makeArrayLinearR P comp sz (apply g . apply f) === + compute (fmap (apply g) (makeArrayLinear comp sz (apply f) :: Array r ix Int)) + +prop_Extract :: + forall r ix. + ( Load D ix Int + , Ragged L ix Int + , Load (R r) ix Int + , Construct r ix Int + , Extract r ix Int + ) + => Comp + -> Sz ix + -> Fun Int Int + -> ix + -> Sz ix + -> Property +prop_Extract comp sz f start newSize = + (computeAs P <$> toStringException (extractM start newSize arrD)) === + (compute <$> toStringException (extractM start newSize arr)) + where + arrD = makeArrayLinearR D comp sz (apply f) + arr = makeArrayLinear comp sz (apply f) :: Array r ix Int + +prop_IxUnbox :: + forall ix. + ( Load D ix ix + , Ragged L ix ix + , Construct U ix ix + , Source U ix ix + ) + => Comp + -> Sz ix + -> Fun Int ix + -> Property +prop_IxUnbox comp sz f = + makeArrayLinearR D comp sz (apply f) === + delay (makeArrayLinear comp sz (apply f) :: Array U ix ix) + +prop_computeWithStride :: + forall r ix. (Load D ix Int, Ragged L ix Int, StrideLoad r ix Int, Construct r ix Int) + => Comp + -> Sz ix + -> Fun Int Int + -> Stride ix + -> Property +prop_computeWithStride comp sz f stride = + arr === computeWithStride stride arrL .&&. + arr === compute (fromStrideLoad stride arrL) + where + arrL = makeArrayLinear comp sz (apply f) :: Array r ix Int + arr = computeWithStrideAs P stride (makeArrayLinearR D comp sz (apply f)) + + +specCommon :: + forall ix. + (Arbitrary ix, Load D ix Int, StrideLoad DW ix Int, Ragged L ix Int, Ragged L ix ix, Unbox ix) + => Spec +specCommon = + describe "Construct" $ do + it "Construct_makeArray B" $ property $ prop_Construct_makeArray_Manifest @B @ix + it "Construct_makeArray N" $ property $ prop_Construct_makeArray_Manifest @N @ix + it "Construct_makeArray S" $ property $ prop_Construct_makeArray_Manifest @S @ix + it "Construct_makeArray P" $ property $ prop_Construct_makeArray_Manifest @P @ix + it "Construct_makeArray U" $ property $ prop_Construct_makeArray_Manifest @U @ix + it "Construct_makeArray_Delayed DI" $ property $ prop_Construct_makeArray_Delayed @DI @ix + it "Construct_makeArray_Delayed DL" $ property $ prop_Construct_makeArray_Delayed @DL @ix + it "Construct_makeArray_Delayed DW" $ property $ prop_Construct_makeArray_Delayed @DW @ix + it "Functor D" $ property $ prop_Functor @D @ix + it "Functor DI" $ property $ prop_Functor @DI @ix + it "Functor DL" $ property $ prop_Functor @DL @ix + it "Functor DW" $ property $ prop_Functor @DW @ix + it "Extract DI" $ property $ prop_Extract @DI @ix + it "Extract B" $ property $ prop_Extract @B @ix + it "Extract N" $ property $ prop_Extract @N @ix + it "Extract S" $ property $ prop_Extract @S @ix + it "Extract U" $ property $ prop_Extract @U @ix + it "computeWithStride DI" $ property $ prop_computeWithStride @DI @ix + it "computeWithStride DW" $ property $ prop_computeWithStride @DW @ix + it "computeWithStride B" $ property $ prop_computeWithStride @B @ix + it "computeWithStride N" $ property $ prop_computeWithStride @N @ix + it "computeWithStride S" $ property $ prop_computeWithStride @S @ix + it "computeWithStride U" $ property $ prop_computeWithStride @U @ix + it "IxUnbox" $ property $ prop_IxUnbox @ix + + +spec :: Spec +spec = do + specCommon @Ix1 + specCommon @Ix2 + specCommon @Ix3 + -- FIXME: Uses too much RAM when compiling + -- specCommon @Ix4 + -- specCommon @Ix5 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import System.IO (BufferMode(LineBuffering), hSetBuffering, stdout) +import Test.Hspec +import Spec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/Test/Massiv/Array/MutableSpec.hs b/tests/Test/Massiv/Array/MutableSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Array/MutableSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Test.Massiv.Array.MutableSpec (spec) where + +import Data.Massiv.Array +import Test.Massiv.Core +import Test.Massiv.Core.Mutable +import Test.Massiv.Array.Mutable + +type MutableArraySpec r ix e + = ( Eq (Array r ix e) + , Show (Array r ix e) + , Eq (Array (R r) Ix1 e) + , Show (Array (R r) Ix1 e) + , Load (R r) ix e + , Extract r ix e + , Resize r ix + , Arbitrary (Array r ix e) + , Mutable r ix e + , Construct r ix e) + +type MutableSpec r e + = ( Show e + , Eq e + , Typeable e + , Arbitrary e + , CoArbitrary e + , Function e + , MutableArraySpec r Ix1 e + , MutableArraySpec r Ix2 e + , MutableArraySpec r Ix3 e + , MutableArraySpec r Ix4 e + , MutableArraySpec r Ix5 e) + +specMutableR :: forall r e. MutableSpec r e => Spec +specMutableR = do + unsafeMutableSpec @r @Ix1 @e + unsafeMutableSpec @r @Ix2 @e + unsafeMutableSpec @r @Ix3 @e + unsafeMutableSpec @r @Ix4 @e + unsafeMutableSpec @r @Ix5 @e + mutableSpec @r @Ix1 @e + mutableSpec @r @Ix2 @e + mutableSpec @r @Ix3 @e + mutableSpec @r @Ix4 @e + --mutableSpec @r @Ix5 @e -- slows down the test suite + + +specUnboxedMutableR :: forall r e. MutableSpec r e => Spec +specUnboxedMutableR = do + specMutableR @r @e + unsafeMutableUnboxedSpec @r @Ix1 @e + unsafeMutableUnboxedSpec @r @Ix2 @e + unsafeMutableUnboxedSpec @r @Ix3 @e + unsafeMutableUnboxedSpec @r @Ix4 @e + unsafeMutableUnboxedSpec @r @Ix5 @e + + + +spec :: Spec +spec = do + specMutableR @B @Int + specMutableR @N @Int + specUnboxedMutableR @S @Int + specUnboxedMutableR @P @Int + specUnboxedMutableR @U @Int + atomicIntSpec @Ix1 + atomicIntSpec @Ix2 + atomicIntSpec @Ix3 + atomicIntSpec @Ix4 + atomicIntSpec @Ix5 diff --git a/tests/Test/Massiv/Core/IndexSpec.hs b/tests/Test/Massiv/Core/IndexSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Core/IndexSpec.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Test.Massiv.Core.IndexSpec (spec) where + +import Control.DeepSeq +import Data.Massiv.Array +import Data.Massiv.Array.Unsafe (Sz(SafeSz)) +import Test.Massiv.Core.Index +import Test.Massiv.Utils +import Test.Validity.Eq (eqSpecOnArbitrary) +import Test.Validity.Ord (ordSpecOnArbitrary) + + + +specIxN :: + forall ix. + ( Num ix + -- , Unbox ix -- TODO: add spec for unboxed vectors + , Index ix + , Bounded ix + , Index (Lower ix) + , Typeable ix + , Typeable (Lower ix) + , Arbitrary ix + , Arbitrary (Lower ix) + ) + => Spec +specIxN = do + describe (showsTypeRep (typeRep (Proxy :: Proxy ix)) "") $ do + ixSpec @ix + ix2UpSpec @ix + ixNumSpec @ix + it "Show" $ property $ \ix -> ("Just (" ++ show (ix :: ix) ++ ")") === show (Just ix) + describe "Bounded" $ do + it "minBound" $ fromIntegral (minBound :: Int) `shouldBe` (minBound :: ix) + it "maxBound" $ fromIntegral (maxBound :: Int) `shouldBe` (maxBound :: ix) + eqSpecOnArbitrary @ix + ordSpecOnArbitrary @ix + describe "Stride" $ do + it "Positive" $ + property $ \(ix :: ix) -> + case Stride ix of + str@(Stride ix') -> foldlIndex (\a x -> a && x > 0) True ix' .&&. + unStride str === liftIndex (max 1) ix + it "Show" $ property $ \str -> ("Just (" ++ show (str :: Stride ix) ++ ")") === show (Just str) + eqSpecOnArbitrary @(Stride ix) + ordSpecOnArbitrary @(Stride ix) + it "DeebpSeq" $ property $ \ (str :: Stride ix) -> rnf str `shouldBe` () + it "oneStride" $ unStride oneStride `shouldBe` (1 :: ix) + it "toLinearIndexStride" $ property $ \ str (SzIx sz ix :: SzIx ix) -> + let k = toLinearIndexStride str sz ix + ix' = fromLinearIndex sz k + in ix' * unStride str + liftIndex2 mod ix (unStride str) === ix + it "strideSize" $ property $ \ (str :: Stride ix) sz -> + let sz' = Sz (unSz sz * unStride str) in strideSize str sz' === sz + it "strideStart" $ property $ \ (str :: Stride ix) ix -> + let start = strideStart str ix + in liftIndex2 mod start (unStride str) === zeroIndex .&&. + ix <= start + + +specIxT :: + forall ix ix'. + ( Typeable ix + , Typeable (Lower ix) + , Index ix + , Index (Lower ix) + , Arbitrary ix + , Arbitrary (Lower ix) + ) + => (ix -> ix') + -> (ix' -> ix) + -> Spec +specIxT fromIxT toIxT = describe (showsTypeRep (typeRep (Proxy :: Proxy ix)) "") $ do + ixSpec @ix + ix2UpSpec @ix + it "toFromIx" $ property $ \ ix -> ix === toIxT (fromIxT ix) + +specPatterns :: Spec +specPatterns = + describe "Patterns" $ do + it "Ix1" $ + property $ \i -> + case i of + Ix1 i' -> i' === Ix1 i + it "Ix2" $ + property $ \i2 i1 -> + case i2 :. i1 of + Ix2 i2' i1' -> i2' :. i1' === Ix2 i2 i1 + it "Ix3" $ + property $ \i3 i2 i1 -> + case i3 :> i2 :. i1 of + Ix3 i3' i2' i1' -> i3' :> i2' :. i1' === Ix3 i3 i2 i1 + it "Ix4" $ + property $ \i4 i3 i2 i1 -> + case i4 :> i3 :> i2 :. i1 of + Ix4 i4' i3' i2' i1' -> i4' :> i3' :> i2' :. i1' === Ix4 i4 i3 i2 i1 + it "Ix5" $ + property $ \i5 i4 i3 i2 i1 -> + case i5 :> i4 :> i3 :> i2 :. i1 of + Ix5 i5' i4' i3' i2' i1' -> i5' :> i4' :> i3' :> i2' :. i1' === Ix5 i5 i4 i3 i2 i1 + it "Sz1" $ + property $ \i -> + case Sz i of + Sz1 i' -> SafeSz i' === Sz1 i + it "Sz2" $ + property $ \i2 i1 -> + case Sz (i2 :. i1) of + Sz2 i2' i1' -> SafeSz (i2' :. i1') === Sz2 i2 i1 + it "Sz3" $ + property $ \i3 i2 i1 -> + case Sz (i3 :> i2 :. i1) of + Sz3 i3' i2' i1' -> SafeSz (i3' :> i2' :. i1') === Sz3 i3 i2 i1 + it "Sz4" $ + property $ \i4 i3 i2 i1 -> + case Sz (i4 :> i3 :> i2 :. i1) of + Sz4 i4' i3' i2' i1' -> SafeSz (i4' :> i3' :> i2' :. i1') === Sz4 i4 i3 i2 i1 + it "Sz5" $ + property $ \i5 i4 i3 i2 i1 -> + case Sz (i5 :> i4 :> i3 :> i2 :. i1) of + Sz5 i5' i4' i3' i2' i1' -> SafeSz (i5' :> i4' :> i3' :> i2' :. i1') === Sz5 i5 i4 i3 i2 i1 + + +specSz :: + forall ix. + ( Num ix + -- , Unbox ix -- TODO: add Unbox instance and a spec for unboxed vectors + , Index ix + , Typeable ix + , Arbitrary ix + ) + => Spec +specSz = do + describe ("Sz (" ++ showsTypeRep (typeRep (Proxy :: Proxy ix)) ")") $ do + szSpec @ix + szNumSpec @ix + it "Show" $ property $ \sz -> ("Just (" ++ show (sz :: Sz ix) ++ ")") === show (Just sz) + eqSpecOnArbitrary @(Sz ix) + ordSpecOnArbitrary @(Sz ix) + +specIx :: Spec +specIx = do + specIx1 + specIxN @Ix2 + specIxN @Ix3 + specIxN @Ix4 + specIxN @Ix5 + describe "Dimension" $ + it "fromDimension" $ do + fromDimension Dim1 `shouldBe` 1 + fromDimension Dim2 `shouldBe` 2 + fromDimension Dim3 `shouldBe` 3 + fromDimension Dim4 `shouldBe` 4 + fromDimension Dim5 `shouldBe` 5 + +spec :: Spec +spec = do + specIx + specIxT @Ix2T toIx2 fromIx2 + specIxT @Ix3T toIx3 fromIx3 + specIxT @Ix4T toIx4 fromIx4 + specIxT @Ix5T toIx5 fromIx5 + specPatterns + specSz @Ix1 + specSz @Ix2 + specSz @Ix3 + specSz @Ix4 + specSz @Ix5 + describe "NFData Border" $ do + it "Fill exception" $ + assertException (ExpectedException==) (Fill (throw ExpectedException :: Int)) + it "rnf" $ property $ \ (b :: Border Int) -> rnf b `shouldBe` () + eqSpecOnArbitrary @(Border Int) diff --git a/tests/Test/Massiv/Core/SchedulerSpec.hs b/tests/Test/Massiv/Core/SchedulerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Core/SchedulerSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Massiv.Core.SchedulerSpec (spec) where + +import Control.Exception.Base (ArithException(DivideByZero)) +import Data.Massiv.Array as A +import Test.Massiv.Core +import Prelude as P + + +-- | Ensure proper exception handling. +prop_CatchDivideByZero :: ArrIx D Ix2 Int -> [Int] -> Property +prop_CatchDivideByZero (ArrIx arr ix) caps = + assertException + (== DivideByZero) + (A.sum $ + A.imap + (\ix' x -> + if ix == ix' + then x `div` 0 + else x) + (setComp (ParOn caps) arr)) + +-- | Ensure proper exception handling in nested parallel computation +prop_CatchNested :: ArrIx D Ix1 (ArrIx D Ix1 Int) -> [Int] -> Property +prop_CatchNested (ArrIx arr ix) caps = + assertException + (== DivideByZero) + (computeAs U $ + A.map A.sum $ + A.imap + (\ix' (ArrIx iarr ixi) -> + if ix == ix' + then A.imap + (\ixi' e -> + if ixi == ixi' + then e `div` 0 + else e) + iarr + else iarr) + (setComp (ParOn caps) arr)) + + +spec :: Spec +spec = + describe "Scheduler - Exceptions" $ do + it "CatchDivideByZero" $ property prop_CatchDivideByZero + it "CatchNested" $ property prop_CatchNested