diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for nonempty-vector +## 0.3 + +* Add `group` and `groupBy`, returning non-empty lists of non-empty vector slices. +* Add `intersperse`. +* Expand property tests across the immutable and mutable APIs, including grouping, + construction, conversions, folds, scans, and type class instances. +* Support GHC 9.14 and `base < 4.23`; update the CI matrix for GHC 9.4–9.14. +* Fix Haddock references and restore the BSD-3-Clause license text. + ## 0.2.3 * Support GHC 9.8.x diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019-2026 Emily Pillmore + +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 Emily Pillmore 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/nonempty-vector.cabal b/nonempty-vector.cabal --- a/nonempty-vector.cabal +++ b/nonempty-vector.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: nonempty-vector -version: 0.2.4 +version: 0.3 synopsis: Non-empty vectors description: Performant, non-empty mutable and immutable vectors homepage: https://github.com/emilypi/nonempty-vector @@ -9,7 +9,7 @@ license-file: LICENSE author: Emily Pillmore maintainer: emilypi@cohomolo.gy -copyright: (c) 2019-2024 Emily Pillmore +copyright: (c) 2019-2026 Emily Pillmore category: Data build-type: Simple extra-doc-files: @@ -17,11 +17,12 @@ README.md tested-with: - GHC ==9.4.4 - || ==9.6.6 + GHC ==9.4.8 + || ==9.6.7 || ==9.8.4 - || ==9.10.1 - || ==9.12.1 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 source-repository head type: git @@ -34,8 +35,8 @@ Data.Vector.NonEmpty.Mutable build-depends: - base >=4.16 && <4.22 - , deepseq + base >=4.16 && <4.23 + , deepseq >=1.4 && <1.6 , primitive >=0.6 && <0.10 , vector >=0.12 && <0.14 @@ -47,8 +48,23 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Test.Data.Vector.NonEmpty.Accessors + Test.Data.Vector.NonEmpty.Construction + Test.Data.Vector.NonEmpty.Conversion + Test.Data.Vector.NonEmpty.Elementwise + Test.Data.Vector.NonEmpty.Folds + Test.Data.Vector.NonEmpty.Grouping + Test.Data.Vector.NonEmpty.Instances + Test.Data.Vector.NonEmpty.Modification + Test.Data.Vector.NonEmpty.Mutable + Test.Data.Vector.NonEmpty.Predicates + Test.Data.Vector.NonEmpty.Scans + Test.Data.Vector.NonEmpty.Util + build-depends: - base >=4.16 && <4.22 + base >=4.16 && <4.23 + , deepseq , nonempty-vector , QuickCheck , tasty diff --git a/src/Data/Vector/NonEmpty.hs b/src/Data/Vector/NonEmpty.hs --- a/src/Data/Vector/NonEmpty.hs +++ b/src/Data/Vector/NonEmpty.hs @@ -1,13 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} -- | -- Module : Data.Vector.NonEmpty --- Copyright : (c) 2019-2024 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style --- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : DataTypeable, CPP +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : DataTypeable, CPP -- -- A library for non-empty boxed vectors (that is, polymorphic arrays capable of -- holding any Haskell value). Non-empty vectors come in two flavors: @@ -18,11 +18,11 @@ -- -- This library attempts to provide support for all standard 'Vector' operations -- in the API, with some slight variation in types and implementation. For example, --- since 'head' and 'foldr' are always gauranteed to be over a non-empty 'Vector', +-- since 'head' and 'foldr' are always guaranteed to be over a non-empty 'Vector', -- it is safe to make use of the 'unsafe-*' 'Vector' operations and semigroupal -- folds available in the API in lieu of the standard implementations. -- --- In contrast, some operations such as 'filter' may "break out" of a 'NonEmptyVector' +-- In contrast, some operations such as 'filter' may "break out" of a t'NonEmptyVector' -- due to the fact that there are no guarantees that may be made on the types of -- 'Bool'-valued functions passed in, hence one could write the following: -- @@ -31,10 +31,10 @@ -- @ -- -- which always produces an empty vector. Thus, some operations must return either --- a 'Maybe' containing a 'NonEmptyVector' or a 'Vector' whenever appropriate. Generally +-- a 'Maybe' containing a t'NonEmptyVector' or a 'Vector' whenever appropriate. Generally -- The former is used in initialization and generation operations, and the latter -- is used in iterative operations where the intent is not to create an instance --- of 'NonEmptyVector'. +-- of t'NonEmptyVector'. -- -- Credit to Roman Leshchinskiy for the original Vector library upon which this is based. -- @@ -180,20 +180,35 @@ , scanl, scanl', scanl1, scanl1', iscanl, iscanl' , prescanr, prescanr', postscanr, postscanr' , scanr, scanr', scanr1, scanr1', iscanr, iscanr' + + -- ** Transformations +, intersperse + + -- ** Grouping +, group +, groupBy + ) where import Prelude ( Bool, Eq, Ord, Num, Enum - , (.), Ordering, max, uncurry, snd) + , (.), Ordering, max, uncurry, snd + , pure, (+), otherwise, (>=), (-), (*), ($), (<=) + , (==), not) import Control.Monad (Monad) import Control.Monad.ST import qualified Data.Foldable as Foldable import Data.Either (Either(..)) +#if MIN_VERSION_base(4,19,0) +-- This import will only execute if compiling with base >= 4.19.0.0 (GHC 9.8+) import Data.Functor hiding (unzip) +#else +import Data.Functor +#endif import Data.Int -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (Maybe(..)) import Data.Semigroup (Semigroup(..), (<>)) @@ -201,7 +216,7 @@ import Data.Vector (Vector) import qualified Data.Vector as V import qualified Data.Vector.Generic as G -import Data.Vector.Mutable (MVector) +import Data.Vector.Mutable (MVector, unsafeWrite) import Data.Vector.NonEmpty.Internal @@ -228,8 +243,8 @@ length = V.length . _neVec {-# INLINE length #-} --- | /O(1)/ First element. Since head is gauranteed, bounds checks --- are bypassed by deferring to 'unsafeHead'. +-- | /O(1)/ First element. Since head is guaranteed, bounds checks +-- are bypassed by deferring to 'Data.Vector.unsafeHead'. -- -- -- >>> head $ unsafeFromList [1..10] @@ -239,8 +254,8 @@ head = V.unsafeHead . _neVec {-# INLINE head #-} --- | /O(1)/ Last element. Since a last element is gauranteed, bounds checks --- are bypassed by deferring to 'unsafeLast'. +-- | /O(1)/ Last element. Since a last element is guaranteed, bounds checks +-- are bypassed by deferring to 'Data.Vector.unsafeLast'. -- -- -- >>> last $ unsafeFromList [1..10] @@ -287,7 +302,7 @@ -- The monad allows operations to be strict in the non-empty vector when -- necessary. -- --- See 'V.indexM' for more details +-- See 'Data.Vector.indexM' for more details -- -- -- >>> indexM @[] (unsafeFromList [1..10]) 3 @@ -299,10 +314,10 @@ -- | /O(1)/ First element of a non-empty vector in a monad. -- --- See 'V.indexM' for an explanation of why this is useful. +-- See 'Data.Vector.indexM' for an explanation of why this is useful. -- --- Note that this function defers to 'unsafeHeadM' since head is --- gauranteed to be safe by construction. +-- Note that this function defers to 'Data.Vector.unsafeHeadM' since head is +-- guaranteed to be safe by construction. -- -- -- >>> headM @[] (unsafeFromList [1..10]) @@ -312,11 +327,11 @@ headM (NonEmptyVector v) = V.unsafeHeadM v {-# INLINE headM #-} --- | /O(1)/ Last element of a non-empty vector in a monad. See 'V.indexM' for an --- explanation of why this is useful. +-- | /O(1)/ Last element of a non-empty vector in a monad. See 'Data.Vector.indexM' +-- for an explanation of why this is useful. -- --- Note that this function defers to 'unsafeHeadM' since a last element is --- gauranteed. +-- Note that this function defers to 'Data.Vector.unsafeLastM' since a last element is +-- guaranteed. -- -- -- >>> lastM @[] (unsafeFromList [1..10]) @@ -1731,7 +1746,7 @@ {-# INLINE izipWith6 #-} -- | /O(min(n,m))/ Elementwise pairing of non-empty vector elements. This is a special case --- of 'zipWith' where the function argument is '(,)' +-- of 'zipWith' where the function argument is @(,)@ -- zip :: NonEmptyVector a -> NonEmptyVector b -> NonEmptyVector (a, b) zip a b = NonEmptyVector (V.zip a' b') @@ -2009,7 +2024,7 @@ -- -- If no elements satisfy the predicate, the resulting vector may be empty. -- --- TODO: this should be a more efficient function in `vector`. +-- TODO: this should be a more efficient function in @vector@. -- -- >>> ifilterM (\i a -> if a == 2 || i == 0 then Just False else Just True) (unsafeFromList [1..3]) -- Just [3] @@ -2646,3 +2661,90 @@ iscanr' :: (Int -> a -> b -> b) -> b -> NonEmptyVector a -> NonEmptyVector b iscanr' f b = NonEmptyVector . V.iscanr' f b . _neVec {-# INLINE iscanr' #-} + +-- | /O(n)/ The 'intersperse' function takes an element and a 'NonEmptyVector' +-- and "intersperses" that element between the elements of the 'NonEmptyVector'. +-- +-- >>> intersperse 0 (unsafeFromList [1,2,3]) +-- [1,0,2,0,3] +-- +-- >>> intersperse 0 (singleton 1) +-- [1] +-- +intersperse :: a -> NonEmptyVector a -> NonEmptyVector a +intersperse sep nev@(NonEmptyVector v) + | V.length v <= 1 = nev + | otherwise = unsafeCreate $ do + let n = V.length v + let newLen = 2*n - 1 + mv <- V.unsafeThaw $ V.replicate newLen (V.unsafeHead v) -- Create mutable vector + + -- Fill the first element + unsafeWrite mv 0 (V.unsafeIndex v 0) + + -- Fill remaining elements with separators + let go i j + | j >= n = pure () + | otherwise = do + unsafeWrite mv i sep + unsafeWrite mv (i+1) (V.unsafeIndex v j) + go (i+2) (j+1) + + go 1 1 + pure mv +{-# INLINE intersperse #-} + +-- | /O(n)/ Split a vector into a list of slices of the input vector. +-- +-- The concatenation of this list of slices is equal to the argument vector, +-- and each slice contains only equal elements. Returns nothing if no equal +-- elements are found. +-- +-- This is the equivalent of 'groupBy (==)'. +-- +-- >>> import qualified Data.NonEmptyVector as NEV +-- >>> NEV.group (NEV.unsafeFromList "Mississippi") +-- "M" :| ["i","ss","i","ss","i","pp","i"] +-- +-- See also 'Data.Vector.group'. +-- +-- @since 0.3 +-- +group :: Eq a => NonEmptyVector a -> NonEmpty (NonEmptyVector a) +group = groupBy (==) + +-- | /O(n)/ Split a vector into a list of slices. +-- +-- +-- The concatenation of this list of slices is equal to the argument vector, +-- and each slice contains only equal elements, as determined by the equality +-- predicate function. +-- + +-- >>> import qualified Data.NonEmptyVector as NEV +-- >>> import Data.Char (isUpper) +-- >>> NEV.groupBy (\a b -> isUpper a == isUpper b) (NEV.unsafeFromList "Mississippi River") +-- "M" :| ["ississippi ","R","iver"] +-- +-- See also 'Data.Vector.groupBy'. +-- +-- @since 0.3 +-- +groupBy + :: Eq a + => (a -> a -> Bool) + -> NonEmptyVector a + -> NonEmpty (NonEmptyVector a) +groupBy f = go + where + go v = + let + h = head v + t = NonEmptyVector $ tail v + in case findIndex (not . f h) t of + Nothing -> v :| [] + Just n -> + let + z = NonEmptyVector $ unsafeTake (n+1) v + x = NonEmptyVector $ unsafeDrop (n+1) v + in z <| go x diff --git a/src/Data/Vector/NonEmpty/Internal.hs b/src/Data/Vector/NonEmpty/Internal.hs --- a/src/Data/Vector/NonEmpty/Internal.hs +++ b/src/Data/Vector/NonEmpty/Internal.hs @@ -4,7 +4,7 @@ {-# LANGUAGE LambdaCase #-} -- | -- Module : Data.Vector.NonEmpty.Internal --- Copyright : (c) 2019-2024 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -12,7 +12,7 @@ -- Portability : non-portable -- -- Internal module exposing the constructors for --- 'NonEmptyVector' and 'NonEmptyMVector'. +-- t'NonEmptyVector' and t'NonEmptyMVector'. -- -- /Warning/: Since the constructors are exposed here, by using this -- module, you take on the risks that you break the non-emptiness @@ -54,13 +54,13 @@ -- ---------------------------------------------------------------------- -- -- Non-empty immutable vectors --- | 'NonEmptyVector' is a thin wrapper around 'Vector' that +-- | t'NonEmptyVector' is a thin wrapper around 'Data.Vector.Vector' that -- witnesses an API requiring non-empty construction, -- initialization, and generation of non-empty vectors by design. -- -- A newtype wrapper was chosen so that no new pointer indirection --- is introduced when working with 'Vector's, and all performance --- characteristics inherited from the 'Vector' API still apply. +-- is introduced when working with 'Data.Vector.Vector's, and all performance +-- characteristics inherited from the "Data.Vector" API still apply. -- -- @since 0.2.1.0 -- @@ -98,8 +98,8 @@ instance Foldable1 NonEmptyVector where foldMap1 f (NonEmptyVector v) = let - h = V.unsafeHead v -- gauranteed head (nonemptiness) - t = V.unsafeTail v -- gauranteed possibly empty tail + h = V.unsafeHead v -- guaranteed head (nonemptiness) + t = V.unsafeTail v -- guaranteed possibly empty tail in go (f h) t -- therefore this is a sound call where go x xs @@ -119,7 +119,7 @@ -- ---------------------------------------------------------------------- -- -- Non-empty mutable vectors --- | 'NonEmptyMVector' is a thin wrapper around 'MVector' that +-- | t'NonEmptyMVector' is a thin wrapper around 'MVector' that -- witnesses an API requiring non-empty construction, -- initialization, and generation of non-empty vectors by design. -- @@ -135,13 +135,13 @@ deriving (Typeable) #endif --- | 'NonEmptyMVector' parametrized by 'PrimState' +-- | t'NonEmptyMVector' parametrized by 'Control.Monad.Primitive.PrimState' 'IO'. -- -- @since 0.2.1.0 -- type NonEmptyIOVector = NonEmptyMVector RealWorld --- | 'NonEmptyMVector' parametrized by 'ST' +-- | t'NonEmptyMVector' parametrized by @t'Control.Monad.Primitive.PrimState' ('ST' s)@. -- -- @since 0.2.1.0 -- diff --git a/src/Data/Vector/NonEmpty/Mutable.hs b/src/Data/Vector/NonEmpty/Mutable.hs --- a/src/Data/Vector/NonEmpty/Mutable.hs +++ b/src/Data/Vector/NonEmpty/Mutable.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Vector.NonEmpty.Mutable --- Copyright : (c) 2019-2024 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,58 +1,42 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -- | -- Module : Main (tests) --- Copyright : 2019-2023 (c) Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD --- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : TypeFamilies +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : TypeFamilies -- module Main ( main ) where -import Data.Maybe -import Data.Vector (Vector) -import Data.Vector.NonEmpty (NonEmptyVector) -import qualified Data.Vector.NonEmpty as NEV +import qualified Test.Data.Vector.NonEmpty.Accessors as Accessors +import qualified Test.Data.Vector.NonEmpty.Construction as Construction +import qualified Test.Data.Vector.NonEmpty.Conversion as Conversion +import qualified Test.Data.Vector.NonEmpty.Elementwise as Elementwise +import qualified Test.Data.Vector.NonEmpty.Folds as Folds +import qualified Test.Data.Vector.NonEmpty.Grouping as Grouping +import qualified Test.Data.Vector.NonEmpty.Instances as Instances +import qualified Test.Data.Vector.NonEmpty.Modification as Modification +import qualified Test.Data.Vector.NonEmpty.Mutable as Mutable +import qualified Test.Data.Vector.NonEmpty.Predicates as Predicates +import qualified Test.Data.Vector.NonEmpty.Scans as Scans -import Test.QuickCheck import Test.Tasty -import Test.Tasty.QuickCheck + main :: IO () -main = defaultMain $ testGroup "NonEmptyVector constructor" - [ testProperty "prop_reverse" prop_reverse - , testProperty "prop_from_to_list" prop_from_to_list - , testProperty "prop_from_to_vec" prop_from_to_vec +main = defaultMain $ testGroup "NonEmptyVector tests" + [ Accessors.tests + , Construction.tests + , Conversion.tests + , Modification.tests + , Elementwise.tests + , Predicates.tests + , Grouping.tests + , Folds.tests + , Scans.tests + , Instances.tests + , Mutable.tests ] - -genList :: Gen [Int] -genList = listOf1 (choose (1, 100)) - -genNEV :: Gen (NonEmptyVector Int) -genNEV = fmap (fromJust . NEV.fromList) genList - -genV :: Gen (Vector Int) -genV = NEV.toVector <$> genNEV - -prop_reverse :: Property -prop_reverse = forAll genNEV $ \t -> - NEV.reverse (NEV.reverse t) == t - -prop_from_to_list :: Property -prop_from_to_list = - forAll genNEV $ \t -> - forAll genList $ \u -> - NEV.fromList (NEV.toList t) == Just t - && fmap NEV.toList (NEV.fromList u) == Just u - -prop_from_to_vec :: Property -prop_from_to_vec = - forAll genNEV $ \t -> - forAll genV $ \u -> - NEV.fromVector (NEV.toVector t) == Just t - && (NEV.toVector <$> NEV.fromVector u) == Just u diff --git a/test/Test/Data/Vector/NonEmpty/Accessors.hs b/test/Test/Data/Vector/NonEmpty/Accessors.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Accessors.hs @@ -0,0 +1,181 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Accessors +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for length information, indexing, and slicing. +-- +module Test.Data.Vector.NonEmpty.Accessors +( tests +) where + + +import Data.Functor.Identity (Identity(..)) +import qualified Data.List as List +import qualified Data.Vector as V +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Accessors" + [ testGroup "Length information" + [ testProperty "prop_length" prop_length + ] + , testGroup "Indexing" + [ testProperty "prop_head" prop_head + , testProperty "prop_last" prop_last + , testProperty "prop_index" prop_index + , testProperty "prop_index_out_of_bounds" prop_index_out_of_bounds + , testProperty "prop_index_maybe" prop_index_maybe + , testProperty "prop_unsafeIndex" prop_unsafeIndex + ] + , testGroup "Monadic indexing" + [ testProperty "prop_headM" prop_headM + , testProperty "prop_lastM" prop_lastM + , testProperty "prop_indexM" prop_indexM + , testProperty "prop_indexM_out_of_bounds" prop_indexM_out_of_bounds + , testProperty "prop_unsafeIndexM" prop_unsafeIndexM + ] + , testGroup "Slicing" + [ testProperty "prop_tail" prop_tail + , testProperty "prop_init" prop_init + , testProperty "prop_uncons" prop_uncons + , testProperty "prop_unsnoc" prop_unsnoc + , testProperty "prop_slice" prop_slice + , testProperty "prop_slice_out_of_bounds" prop_slice_out_of_bounds + , testProperty "prop_take" prop_take + , testProperty "prop_drop" prop_drop + , testProperty "prop_splitAt" prop_splitAt + , testProperty "prop_unsafeSlice" prop_unsafeSlice + , testProperty "prop_unsafeTake" prop_unsafeTake + , testProperty "prop_unsafeDrop" prop_unsafeDrop + ] + ] + +-- ---------------------------------------------------------------------- -- +-- Length information + +prop_length :: NonEmptyVector Int -> Property +prop_length v = NEV.length v === List.length (elems v) + +-- ---------------------------------------------------------------------- -- +-- Indexing + +prop_head :: NonEmptyVector Int -> Property +prop_head v = [NEV.head v] === List.take 1 (elems v) + +prop_last :: NonEmptyVector Int -> Property +prop_last v = [NEV.last v] === List.take 1 (List.reverse (elems v)) + +prop_index :: NonEmptyVector Int -> Property +prop_index v = forAll (genIndex v) $ \i -> + Just (v NEV.! i) === lookupList i (elems v) + +prop_index_out_of_bounds :: NonEmptyVector Int -> Property +prop_index_out_of_bounds v = forAll (genOutOfBounds v) $ \i -> + throws (v NEV.! i) + +prop_index_maybe :: NonEmptyVector Int -> Int -> Property +prop_index_maybe v i = v NEV.!? i === lookupList i (elems v) + +prop_unsafeIndex :: NonEmptyVector Int -> Property +prop_unsafeIndex v = forAll (genIndex v) $ \i -> + Just (NEV.unsafeIndex v i) === lookupList i (elems v) + +-- ---------------------------------------------------------------------- -- +-- Monadic indexing + +prop_headM :: NonEmptyVector Int -> Property +prop_headM v = [runIdentity (NEV.headM v)] === List.take 1 (elems v) + +prop_lastM :: NonEmptyVector Int -> Property +prop_lastM v = + [runIdentity (NEV.lastM v)] === List.take 1 (List.reverse (elems v)) + +prop_indexM :: NonEmptyVector Int -> Property +prop_indexM v = forAll (genIndex v) $ \i -> + Just (runIdentity (NEV.indexM v i)) === lookupList i (elems v) + +prop_indexM_out_of_bounds :: NonEmptyVector Int -> Property +prop_indexM_out_of_bounds v = forAll (genOutOfBounds v) $ \i -> + throws (runIdentity (NEV.indexM v i)) + +prop_unsafeIndexM :: NonEmptyVector Int -> Property +prop_unsafeIndexM v = forAll (genIndex v) $ \i -> + Just (runIdentity (NEV.unsafeIndexM v i)) === lookupList i (elems v) + +-- ---------------------------------------------------------------------- -- +-- Slicing + +prop_tail :: NonEmptyVector Int -> Property +prop_tail v = V.toList (NEV.tail v) === List.drop 1 (elems v) + +prop_init :: NonEmptyVector Int -> Property +prop_init v = + V.toList (NEV.init v) === List.take (List.length as - 1) as + where + as = elems v + +prop_uncons :: NonEmptyVector Int -> Property +prop_uncons v = ([a], V.toList as) === List.splitAt 1 (elems v) + where + (a, as) = NEV.uncons v + +prop_unsnoc :: NonEmptyVector Int -> Property +prop_unsnoc v = + (V.toList as, [a]) === List.splitAt (List.length (elems v) - 1) (elems v) + where + (as, a) = NEV.unsnoc v + +prop_slice :: NonEmptyVector Int -> Property +prop_slice v = forAll (genSlice v) $ \(i, m) -> + V.toList (NEV.slice i m v) === List.take m (List.drop i (elems v)) + +prop_slice_out_of_bounds :: NonEmptyVector Int -> Property +prop_slice_out_of_bounds v = forAll genBadSlice $ \(i, m) -> + throws (V.toList (NEV.slice i m v)) + where + n = NEV.length v + + genBadSlice = oneof + [ (,) <$> choose (-10, -1) <*> choose (0, n) + , (,) <$> choose (0, n) <*> choose (-10, -1) + , do + i <- choose (0, n) + m <- choose (n - i + 1, n - i + 10) + pure (i, m) + ] + +prop_take :: Int -> NonEmptyVector Int -> Property +prop_take n v = V.toList (NEV.take n v) === List.take n (elems v) + +prop_drop :: Int -> NonEmptyVector Int -> Property +prop_drop n v = V.toList (NEV.drop n v) === List.drop n (elems v) + +prop_splitAt :: Int -> NonEmptyVector Int -> Property +prop_splitAt n v = + (V.toList as, V.toList bs) === List.splitAt n (elems v) + where + (as, bs) = NEV.splitAt n v + +prop_unsafeSlice :: NonEmptyVector Int -> Property +prop_unsafeSlice v = forAll (genSlice v) $ \(i, m) -> + V.toList (NEV.unsafeSlice i m v) === List.take m (List.drop i (elems v)) + +prop_unsafeTake :: NonEmptyVector Int -> Property +prop_unsafeTake v = forAll (choose (0, NEV.length v)) $ \n -> + V.toList (NEV.unsafeTake n v) === List.take n (elems v) + +prop_unsafeDrop :: NonEmptyVector Int -> Property +prop_unsafeDrop v = forAll (choose (0, NEV.length v)) $ \n -> + V.toList (NEV.unsafeDrop n v) === List.drop n (elems v) diff --git a/test/Test/Data/Vector/NonEmpty/Construction.hs b/test/Test/Data/Vector/NonEmpty/Construction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Construction.hs @@ -0,0 +1,316 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Construction +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for initialization, unfolding, enumeration, and +-- concatenation. +-- +-- The 'Maybe'-valued constructors must yield 'Nothing' exactly when the +-- result would be empty, and the @*1@ variants must clamp their size to at +-- least one. +-- +module Test.Data.Vector.NonEmpty.Construction +( tests +) where + + +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Vector as V +import qualified Data.Vector.NonEmpty as NEV +import Data.Vector.NonEmpty.Internal (NonEmptyVector(..)) + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Construction" + [ testGroup "Initialization" + [ testProperty "prop_singleton" prop_singleton + , testProperty "prop_replicate" prop_replicate + , testProperty "prop_replicate1" prop_replicate1 + , testProperty "prop_generate" prop_generate + , testProperty "prop_generate1" prop_generate1 + , testProperty "prop_iterateN" prop_iterateN + , testProperty "prop_iterateN1" prop_iterateN1 + ] + , testGroup "Monadic initialization" + [ testProperty "prop_replicateM" prop_replicateM + , testProperty "prop_replicate1M" prop_replicate1M + , testProperty "prop_generateM" prop_generateM + , testProperty "prop_generate1M" prop_generate1M + , testProperty "prop_iterateNM" prop_iterateNM + , testProperty "prop_iterateN1M" prop_iterateN1M + , testProperty "prop_create" prop_create + , testProperty "prop_unsafeCreate" prop_unsafeCreate + , testProperty "prop_createT" prop_createT + , testProperty "prop_unsafeCreateT" prop_unsafeCreateT + ] + , testGroup "Unfolding" + [ testProperty "prop_unfoldr" prop_unfoldr + , testProperty "prop_unfoldr1" prop_unfoldr1 + , testProperty "prop_unfoldrN" prop_unfoldrN + , testProperty "prop_unfoldr1N" prop_unfoldr1N + , testProperty "prop_unfoldrM" prop_unfoldrM + , testProperty "prop_unfoldr1M" prop_unfoldr1M + , testProperty "prop_unfoldrNM" prop_unfoldrNM + , testProperty "prop_unfoldr1NM" prop_unfoldr1NM + , testProperty "prop_constructN" prop_constructN + , testProperty "prop_constructrN" prop_constructrN + ] + , testGroup "Enumeration" + [ testProperty "prop_enumFromN" prop_enumFromN + , testProperty "prop_enumFromN1" prop_enumFromN1 + , testProperty "prop_enumFromStepN" prop_enumFromStepN + , testProperty "prop_enumFromStepN1" prop_enumFromStepN1 + , testProperty "prop_enumFromTo" prop_enumFromTo + , testProperty "prop_enumFromThenTo" prop_enumFromThenTo + ] + , testGroup "Concatenation" + [ testProperty "prop_cons" prop_cons + , testProperty "prop_consV" prop_consV + , testProperty "prop_snoc" prop_snoc + , testProperty "prop_snocV" prop_snocV + , testProperty "prop_append" prop_append + , testProperty "prop_concat" prop_concat + , testProperty "prop_concat1" prop_concat1 + ] + , testGroup "Restricting memory usage" + [ testProperty "prop_force" prop_force + ] + ] + +-- ---------------------------------------------------------------------- -- +-- Initialization + +prop_singleton :: Int -> Property +prop_singleton a = elems (NEV.singleton a) === [a] + +prop_replicate :: Int -> Int -> Property +prop_replicate n a = + fmap elems (NEV.replicate n a) === whenNonEmpty (List.replicate n a) + +prop_replicate1 :: Int -> Int -> Property +prop_replicate1 n a = + elems (NEV.replicate1 n a) === List.replicate (max n 1) a + +prop_generate :: Int -> Fun Int Int -> Property +prop_generate n (Fn f) = + fmap elems (NEV.generate n f) === whenNonEmpty (fmap f [0 .. n - 1]) + +prop_generate1 :: Int -> Fun Int Int -> Property +prop_generate1 n (Fn f) = + elems (NEV.generate1 n f) === fmap f [0 .. max n 1 - 1] + +prop_iterateN :: Int -> Fun Int Int -> Int -> Property +prop_iterateN n (Fn f) a = + fmap elems (NEV.iterateN n f a) + === whenNonEmpty (List.take n (List.iterate f a)) + +prop_iterateN1 :: Int -> Fun Int Int -> Int -> Property +prop_iterateN1 n (Fn f) a = + elems (NEV.iterateN1 n f a) === List.take (max n 1) (List.iterate f a) + +-- ---------------------------------------------------------------------- -- +-- Monadic initialization + +prop_replicateM :: Int -> Int -> Property +prop_replicateM n a = + fmap (fmap elems) (NEV.replicateM n (logged () a)) + === (List.replicate n (), whenNonEmpty (List.replicate n a)) + +prop_replicate1M :: Int -> Int -> Property +prop_replicate1M n a = + fmap elems (NEV.replicate1M n (logged () a)) + === (List.replicate n' (), List.replicate n' a) + where + n' = max n 1 + +prop_generateM :: Int -> Fun Int Int -> Property +prop_generateM n (Fn f) = + fmap (fmap elems) (NEV.generateM n (\i -> logged i (f i))) + === (is, whenNonEmpty (fmap f is)) + where + is = [0 .. n - 1] + +prop_generate1M :: Int -> Fun Int Int -> Property +prop_generate1M n (Fn f) = + fmap elems (NEV.generate1M n (\i -> logged i (f i))) + === (is, fmap f is) + where + is = [0 .. max n 1 - 1] + +-- The step function runs once per element after the seed. +prop_iterateNM :: Int -> Fun Int Int -> Int -> Property +prop_iterateNM n (Fn f) a = + fmap (fmap elems) (NEV.iterateNM n (\b -> logged b (f b)) a) + === (List.take (n - 1) as, whenNonEmpty (List.take n as)) + where + as = List.iterate f a + +prop_iterateN1M :: Int -> Fun Int Int -> Int -> Property +prop_iterateN1M n (Fn f) a = + fmap elems (NEV.iterateN1M n (\b -> logged b (f b)) a) + === (List.take (n' - 1) as, List.take n' as) + where + n' = max n 1 + as = List.iterate f a + +prop_create :: [Int] -> Property +prop_create as = + fmap elems (NEV.create (V.thaw (V.fromList as))) === whenNonEmpty as + +prop_unsafeCreate :: NonEmptyVector Int -> Property +prop_unsafeCreate v = + elems (NEV.unsafeCreate (V.thaw (V.fromList (elems v)))) === elems v + +prop_createT :: [[Int]] -> Property +prop_createT ass = + fmap (fmap elems) (NEV.createT (traverse (V.thaw . V.fromList) ass)) + === fmap whenNonEmpty ass + +prop_unsafeCreateT :: [NonEmptyVector Int] -> Property +prop_unsafeCreateT vs = + fmap elems (NEV.unsafeCreateT (traverse (V.thaw . V.fromList . elems) vs)) + === fmap elems vs + +-- ---------------------------------------------------------------------- -- +-- Unfolding + +prop_unfoldr :: Fun Int Int -> Int -> Property +prop_unfoldr (Fn f) b = + fmap elems (NEV.unfoldr (unfoldStep f) b) + === whenNonEmpty (List.unfoldr (unfoldStep f) b) + +prop_unfoldr1 :: Fun Int Int -> Int -> Int -> Property +prop_unfoldr1 (Fn f) a b = + elems (NEV.unfoldr1 (unfoldStep f) a b) + === a : List.unfoldr (unfoldStep f) b + +prop_unfoldrN :: Int -> Fun Int Int -> Int -> Property +prop_unfoldrN n (Fn f) b = + fmap elems (NEV.unfoldrN n (unfoldStep f) b) + === whenNonEmpty (List.take n (List.unfoldr (unfoldStep f) b)) + +-- The initial element is supplied in addition to at most @n@ unfolded ones. +prop_unfoldr1N :: Int -> Fun Int Int -> Int -> Int -> Property +prop_unfoldr1N n (Fn f) a b = + elems (NEV.unfoldr1N n (unfoldStep f) a b) + === a : List.take n (List.unfoldr (unfoldStep f) b) + +prop_unfoldrM :: Fun Int Int -> Int -> Property +prop_unfoldrM (Fn f) b = + fmap (fmap elems) (NEV.unfoldrM step b) + === fmap whenNonEmpty (unfoldrMList step b) + where + step s = logged s (unfoldStep f s) + +prop_unfoldr1M :: Fun Int Int -> Int -> Int -> Property +prop_unfoldr1M (Fn f) a b = + fmap elems (NEV.unfoldr1M step a b) === fmap (a :) (unfoldrMList step b) + where + step s = logged s (unfoldStep f s) + +prop_unfoldrNM :: Int -> Fun Int Int -> Int -> Property +prop_unfoldrNM n (Fn f) b = + fmap (fmap elems) (NEV.unfoldrNM n step b) + === fmap whenNonEmpty (unfoldrNMList n step b) + where + step s = logged s (unfoldStep f s) + +prop_unfoldr1NM :: Int -> Fun Int Int -> Int -> Int -> Property +prop_unfoldr1NM n (Fn f) a b = + fmap elems (NEV.unfoldr1NM n step a b) + === fmap (a :) (unfoldrNMList n step b) + where + step s = logged s (unfoldStep f s) + +-- Each element is generated from the prefix constructed so far. +prop_constructN :: Fun [Int] Int -> Property +prop_constructN (Fn f) = forAll (choose (0, 30)) $ \n -> + fmap elems (NEV.constructN n (f . V.toList)) + === whenNonEmpty (construct n []) + where + construct n acc + | List.length acc >= n = acc + | otherwise = construct n (acc ++ [f acc]) + +-- Each element is generated from the suffix constructed so far. +prop_constructrN :: Fun [Int] Int -> Property +prop_constructrN (Fn f) = forAll (choose (0, 30)) $ \n -> + fmap elems (NEV.constructrN n (f . V.toList)) + === whenNonEmpty (construct n []) + where + construct n acc + | List.length acc >= n = acc + | otherwise = construct n (f acc : acc) + +-- ---------------------------------------------------------------------- -- +-- Enumeration + +prop_enumFromN :: Int -> Int -> Property +prop_enumFromN a n = + fmap elems (NEV.enumFromN a n) === whenNonEmpty (fmap (a +) [0 .. n - 1]) + +prop_enumFromN1 :: Int -> Int -> Property +prop_enumFromN1 a n = + elems (NEV.enumFromN1 a n) === fmap (a +) [0 .. max n 1 - 1] + +prop_enumFromStepN :: Int -> Int -> Int -> Property +prop_enumFromStepN a s n = + fmap elems (NEV.enumFromStepN a s n) + === whenNonEmpty [ a + s * i | i <- [0 .. n - 1] ] + +prop_enumFromStepN1 :: Int -> Int -> Int -> Property +prop_enumFromStepN1 a s n = + elems (NEV.enumFromStepN1 a s n) === [ a + s * i | i <- [0 .. max n 1 - 1] ] + +prop_enumFromTo :: Int -> Int -> Property +prop_enumFromTo a b = fmap elems (NEV.enumFromTo a b) === whenNonEmpty [a .. b] + +-- A zero step would enumerate forever. +prop_enumFromThenTo :: Int -> Int -> Int -> Property +prop_enumFromThenTo a b c = a /= b ==> + fmap elems (NEV.enumFromThenTo a b c) === whenNonEmpty [a, b .. c] + +-- ---------------------------------------------------------------------- -- +-- Concatenation + +prop_cons :: Int -> NonEmptyVector Int -> Property +prop_cons a v = elems (NEV.cons a v) === a : elems v + +prop_consV :: Int -> [Int] -> Property +prop_consV a as = elems (NEV.consV a (V.fromList as)) === a : as + +prop_snoc :: NonEmptyVector Int -> Int -> Property +prop_snoc v a = elems (NEV.snoc v a) === elems v ++ [a] + +prop_snocV :: [Int] -> Int -> Property +prop_snocV as a = elems (NEV.snocV (V.fromList as) a) === as ++ [a] + +prop_append :: NonEmptyVector Int -> NonEmptyVector Int -> Property +prop_append v w = elems (v NEV.++ w) === elems v ++ elems w + +prop_concat :: [NonEmptyVector Int] -> Property +prop_concat vs = + fmap elems (NEV.concat vs) === whenNonEmpty (List.concatMap elems vs) + +prop_concat1 :: NonEmptyVector Int -> [NonEmptyVector Int] -> Property +prop_concat1 v vs = + elems (NEV.concat1 (v :| vs)) === List.concatMap elems (v : vs) + +-- ---------------------------------------------------------------------- -- +-- Restricting memory usage + +prop_force :: NonEmptyVector Int -> Property +prop_force v = forAll (genSlice v) $ \(i, m) -> m > 0 ==> + let w = NonEmptyVector (V.slice i m (_neVec v)) + in elems (NEV.force w) === List.take m (List.drop i (elems v)) diff --git a/test/Test/Data/Vector/NonEmpty/Conversion.hs b/test/Test/Data/Vector/NonEmpty/Conversion.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Conversion.hs @@ -0,0 +1,115 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Conversion +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for conversions to and from non-empty lists, vectors, and +-- lists. +-- +module Test.Data.Vector.NonEmpty.Conversion +( tests +) where + + +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Vector as V +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Conversion" + [ testGroup "To/from non-empty lists" + [ testProperty "prop_toNonEmpty" prop_toNonEmpty + , testProperty "prop_fromNonEmpty" prop_fromNonEmpty + , testProperty "prop_from_to_nonempty" prop_from_to_nonempty + , testProperty "prop_fromNonEmptyN" prop_fromNonEmptyN + , testProperty "prop_fromNonEmptyN1" prop_fromNonEmptyN1 + , testProperty "prop_unsafeFromList" prop_unsafeFromList + ] + , testGroup "To/from vector" + [ testProperty "prop_toVector" prop_toVector + , testProperty "prop_fromVector" prop_fromVector + , testProperty "prop_unsafeFromVector" prop_unsafeFromVector + , testProperty "prop_from_to_vec" prop_from_to_vec + ] + , testGroup "To/from list" + [ testProperty "prop_toList" prop_toList + , testProperty "prop_fromList" prop_fromList + , testProperty "prop_fromListN" prop_fromListN + , testProperty "prop_from_to_list" prop_from_to_list + ] + ] + +-- ---------------------------------------------------------------------- -- +-- To/from non-empty lists + +prop_toNonEmpty :: NonEmptyVector Int -> Property +prop_toNonEmpty v = NEV.toNonEmpty v === elems1 v + +prop_fromNonEmpty :: Int -> [Int] -> Property +prop_fromNonEmpty a as = elems (NEV.fromNonEmpty (a :| as)) === a : as + +prop_from_to_nonempty :: NonEmptyVector Int -> Property +prop_from_to_nonempty v = NEV.fromNonEmpty (NEV.toNonEmpty v) === v + +prop_fromNonEmptyN :: Int -> Int -> [Int] -> Property +prop_fromNonEmptyN n a as = + fmap elems (NEV.fromNonEmptyN n (a :| as)) + === whenNonEmpty (List.take n (a : as)) + +prop_fromNonEmptyN1 :: Int -> Int -> [Int] -> Property +prop_fromNonEmptyN1 n a as = + elems (NEV.fromNonEmptyN1 n (a :| as)) === List.take (max n 1) (a : as) + +prop_unsafeFromList :: NonEmptyList Int -> Property +prop_unsafeFromList (NonEmpty as) = elems (NEV.unsafeFromList as) === as + +-- ---------------------------------------------------------------------- -- +-- To/from vector + +prop_toVector :: NonEmptyVector Int -> Property +prop_toVector v = V.toList (NEV.toVector v) === elems v + +prop_fromVector :: [Int] -> Property +prop_fromVector as = + fmap elems (NEV.fromVector (V.fromList as)) === whenNonEmpty as + +prop_unsafeFromVector :: NonEmptyList Int -> Property +prop_unsafeFromVector (NonEmpty as) = + elems (NEV.unsafeFromVector (V.fromList as)) === as + +prop_from_to_vec :: NonEmptyVector Int -> NonEmptyList Int -> Property +prop_from_to_vec t (NonEmpty as) = + NEV.fromVector (NEV.toVector t) === Just t + .&&. (NEV.toVector <$> NEV.fromVector u) === Just u + where + u = V.fromList as + +-- ---------------------------------------------------------------------- -- +-- To/from list + +prop_toList :: NonEmptyVector Int -> Property +prop_toList v = NEV.toList v === elems v + +prop_fromList :: [Int] -> Property +prop_fromList as = fmap elems (NEV.fromList as) === whenNonEmpty as + +prop_fromListN :: Int -> [Int] -> Property +prop_fromListN n as = + fmap elems (NEV.fromListN n as) === whenNonEmpty (List.take n as) + +prop_from_to_list :: NonEmptyVector Int -> NonEmptyList Int -> Property +prop_from_to_list t (NonEmpty u) = + NEV.fromList (NEV.toList t) === Just t + .&&. fmap NEV.toList (NEV.fromList u) === Just u diff --git a/test/Test/Data/Vector/NonEmpty/Elementwise.hs b/test/Test/Data/Vector/NonEmpty/Elementwise.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Elementwise.hs @@ -0,0 +1,284 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Elementwise +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for indexing, mapping, zipping, and unzipping. +-- +-- Monadic operations run in a writer-style @([w], -)@ monad so that the +-- order and number of effects are observable. +-- +module Test.Data.Vector.NonEmpty.Elementwise +( tests +) where + + +import qualified Data.List as List +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Elementwise" + [ testGroup "Indexing" + [ testProperty "prop_indexed" prop_indexed + ] + , testGroup "Mapping" + [ testProperty "prop_map" prop_map + , testProperty "prop_imap" prop_imap + , testProperty "prop_concatMap" prop_concatMap + ] + , testGroup "Monadic mapping" + [ testProperty "prop_mapM" prop_mapM + , testProperty "prop_imapM" prop_imapM + , testProperty "prop_mapM_" prop_mapM_ + , testProperty "prop_imapM_" prop_imapM_ + , testProperty "prop_forM" prop_forM + , testProperty "prop_forM_" prop_forM_ + ] + , testGroup "Zipping" + [ testProperty "prop_zipWith" prop_zipWith + , testProperty "prop_zipWith3" prop_zipWith3 + , testProperty "prop_zipWith4" prop_zipWith4 + , testProperty "prop_zipWith5" prop_zipWith5 + , testProperty "prop_zipWith6" prop_zipWith6 + , testProperty "prop_izipWith" prop_izipWith + , testProperty "prop_izipWith3" prop_izipWith3 + , testProperty "prop_izipWith4" prop_izipWith4 + , testProperty "prop_izipWith5" prop_izipWith5 + , testProperty "prop_izipWith6" prop_izipWith6 + , testProperty "prop_zip" prop_zip + , testProperty "prop_zip3" prop_zip3 + , testProperty "prop_zip4" prop_zip4 + , testProperty "prop_zip5" prop_zip5 + , testProperty "prop_zip6" prop_zip6 + ] + , testGroup "Monadic zipping" + [ testProperty "prop_zipWithM" prop_zipWithM + , testProperty "prop_zipWithM_" prop_zipWithM_ + , testProperty "prop_izipWithM" prop_izipWithM + , testProperty "prop_izipWithM_" prop_izipWithM_ + ] + , testGroup "Unzipping" + [ testProperty "prop_unzip" prop_unzip + , testProperty "prop_unzip3" prop_unzip3 + , testProperty "prop_unzip4" prop_unzip4 + , testProperty "prop_unzip5" prop_unzip5 + , testProperty "prop_unzip6" prop_unzip6 + ] + ] + +type V = NonEmptyVector Int + +-- ---------------------------------------------------------------------- -- +-- Indexing + +prop_indexed :: V -> Property +prop_indexed v = elems (NEV.indexed v) === List.zip [0 ..] (elems v) + +-- ---------------------------------------------------------------------- -- +-- Mapping + +prop_map :: Fun Int Int -> V -> Property +prop_map (Fn f) v = elems (NEV.map f v) === List.map f (elems v) + +prop_imap :: Fun (Int, Int) Int -> V -> Property +prop_imap (Fn2 f) v = elems (NEV.imap f v) === List.zipWith f [0 ..] (elems v) + +prop_concatMap :: Fun Int V -> V -> Property +prop_concatMap (Fn f) v = + elems (NEV.concatMap f v) === List.concatMap (elems . f) (elems v) + +-- ---------------------------------------------------------------------- -- +-- Monadic mapping + +prop_mapM :: Fun Int Int -> V -> Property +prop_mapM (Fn f) v = + fmap elems (NEV.mapM (\a -> logged a (f a)) v) + === (elems v, List.map f (elems v)) + +prop_imapM :: Fun (Int, Int) Int -> V -> Property +prop_imapM (Fn2 f) v = + fmap elems (NEV.imapM (\i a -> logged i (f i a)) v) + === (is, List.zipWith f is (elems v)) + where + is = [0 .. NEV.length v - 1] + +prop_mapM_ :: V -> Property +prop_mapM_ v = NEV.mapM_ (\a -> logged a a) v === (elems v, ()) + +prop_imapM_ :: V -> Property +prop_imapM_ v = + NEV.imapM_ (\i a -> logged (i, a) a) v + === (List.zip [0 ..] (elems v), ()) + +prop_forM :: Fun Int Int -> V -> Property +prop_forM (Fn f) v = + fmap elems (NEV.forM v (\a -> logged a (f a))) + === (elems v, List.map f (elems v)) + +prop_forM_ :: V -> Property +prop_forM_ v = NEV.forM_ v (\a -> logged a a) === (elems v, ()) + +-- ---------------------------------------------------------------------- -- +-- Zipping +-- +-- The higher arities collect their arguments in order, so the models +-- detect both truncation to the shortest input and argument order. + +prop_zipWith :: Fun (Int, Int) Int -> V -> V -> Property +prop_zipWith (Fn2 f) a b = + elems (NEV.zipWith f a b) === List.zipWith f (elems a) (elems b) + +prop_zipWith3 :: Fun (Int, Int, Int) Int -> V -> V -> V -> Property +prop_zipWith3 (Fn3 f) a b c = + elems (NEV.zipWith3 f a b c) + === List.zipWith3 f (elems a) (elems b) (elems c) + +prop_zipWith4 :: V -> V -> V -> V -> Property +prop_zipWith4 a b c d = + elems (NEV.zipWith4 k a b c d) + === List.zipWith4 k (elems a) (elems b) (elems c) (elems d) + where + k p q r s = [p, q, r, s] + +prop_zipWith5 :: V -> V -> V -> V -> V -> Property +prop_zipWith5 a b c d e = + elems (NEV.zipWith5 k a b c d e) + === List.zipWith5 k (elems a) (elems b) (elems c) (elems d) (elems e) + where + k p q r s t = [p, q, r, s, t] + +prop_zipWith6 :: V -> V -> V -> V -> V -> V -> Property +prop_zipWith6 a b c d e f = + elems (NEV.zipWith6 k a b c d e f) + === List.zipWith6 k + (elems a) (elems b) (elems c) (elems d) (elems e) (elems f) + where + k p q r s t u = [p, q, r, s, t, u] + +prop_izipWith :: V -> V -> Property +prop_izipWith a b = + elems (NEV.izipWith k a b) === List.zipWith3 k [0 ..] (elems a) (elems b) + where + k i p q = [i, p, q] + +prop_izipWith3 :: V -> V -> V -> Property +prop_izipWith3 a b c = + elems (NEV.izipWith3 k a b c) + === List.zipWith4 k [0 ..] (elems a) (elems b) (elems c) + where + k i p q r = [i, p, q, r] + +prop_izipWith4 :: V -> V -> V -> V -> Property +prop_izipWith4 a b c d = + elems (NEV.izipWith4 k a b c d) + === List.zipWith5 k [0 ..] (elems a) (elems b) (elems c) (elems d) + where + k i p q r s = [i, p, q, r, s] + +prop_izipWith5 :: V -> V -> V -> V -> V -> Property +prop_izipWith5 a b c d e = + elems (NEV.izipWith5 k a b c d e) + === List.zipWith6 k [0 ..] + (elems a) (elems b) (elems c) (elems d) (elems e) + where + k i p q r s t = [i, p, q, r, s, t] + +prop_izipWith6 :: V -> V -> V -> V -> V -> V -> Property +prop_izipWith6 a b c d e f = + elems (NEV.izipWith6 k a b c d e f) + === List.zipWith7 k [0 ..] + (elems a) (elems b) (elems c) (elems d) (elems e) (elems f) + where + k i p q r s t u = [i, p, q, r, s, t, u] + +prop_zip :: V -> V -> Property +prop_zip a b = elems (NEV.zip a b) === List.zip (elems a) (elems b) + +prop_zip3 :: V -> V -> V -> Property +prop_zip3 a b c = + elems (NEV.zip3 a b c) === List.zip3 (elems a) (elems b) (elems c) + +prop_zip4 :: V -> V -> V -> V -> Property +prop_zip4 a b c d = + elems (NEV.zip4 a b c d) + === List.zip4 (elems a) (elems b) (elems c) (elems d) + +prop_zip5 :: V -> V -> V -> V -> V -> Property +prop_zip5 a b c d e = + elems (NEV.zip5 a b c d e) + === List.zip5 (elems a) (elems b) (elems c) (elems d) (elems e) + +prop_zip6 :: V -> V -> V -> V -> V -> V -> Property +prop_zip6 a b c d e f = + elems (NEV.zip6 a b c d e f) + === List.zip6 (elems a) (elems b) (elems c) (elems d) (elems e) (elems f) + +-- ---------------------------------------------------------------------- -- +-- Monadic zipping + +prop_zipWithM :: Fun (Int, Int) Int -> V -> V -> Property +prop_zipWithM (Fn2 f) a b = + fmap elems (NEV.zipWithM (\p q -> logged (p, q) (f p q)) a b) + === (ps, List.map (uncurry f) ps) + where + ps = List.zip (elems a) (elems b) + +prop_zipWithM_ :: V -> V -> Property +prop_zipWithM_ a b = + NEV.zipWithM_ (\p q -> logged (p, q) p) a b + === (List.zip (elems a) (elems b), ()) + +prop_izipWithM :: Fun (Int, Int, Int) Int -> V -> V -> Property +prop_izipWithM (Fn3 f) a b = + fmap elems (NEV.izipWithM (\i p q -> logged i (f i p q)) a b) + === (List.map fst ips, List.map (\(i, (p, q)) -> f i p q) ips) + where + ips = List.zip [0 ..] (List.zip (elems a) (elems b)) + +prop_izipWithM_ :: V -> V -> Property +prop_izipWithM_ a b = + NEV.izipWithM_ (\i p q -> logged (i, p, q) p) a b + === (List.zip3 [0 ..] (elems a) (elems b), ()) + +-- ---------------------------------------------------------------------- -- +-- Unzipping + +prop_unzip :: NonEmptyVector (Int, Int) -> Property +prop_unzip v = (elems a, elems b) === List.unzip (elems v) + where + (a, b) = NEV.unzip v + +prop_unzip3 :: NonEmptyVector (Int, Int, Int) -> Property +prop_unzip3 v = (elems a, elems b, elems c) === List.unzip3 (elems v) + where + (a, b, c) = NEV.unzip3 v + +prop_unzip4 :: NonEmptyVector (Int, Int, Int, Int) -> Property +prop_unzip4 v = + (elems a, elems b, elems c, elems d) === List.unzip4 (elems v) + where + (a, b, c, d) = NEV.unzip4 v + +prop_unzip5 :: NonEmptyVector (Int, Int, Int, Int, Int) -> Property +prop_unzip5 v = + (elems a, elems b, elems c, elems d, elems e) === List.unzip5 (elems v) + where + (a, b, c, d, e) = NEV.unzip5 v + +prop_unzip6 :: NonEmptyVector (Int, Int, Int, Int, Int, Int) -> Property +prop_unzip6 v = + (elems a, elems b, elems c, elems d, elems e, elems f) + === List.unzip6 (elems v) + where + (a, b, c, d, e, f) = NEV.unzip6 v diff --git a/test/Test/Data/Vector/NonEmpty/Folds.hs b/test/Test/Data/Vector/NonEmpty/Folds.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Folds.hs @@ -0,0 +1,309 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Folds +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for folds, specialized folds, monadic folds, and sequencing. +-- +-- Fold functions are arbitrary, hence neither associative nor commutative, +-- so the models pin down fold direction and argument order. Monadic folds +-- run in a writer-style @([w], -)@ monad to expose effect order. +-- +module Test.Data.Vector.NonEmpty.Folds +( tests +) where + + +import qualified Control.Monad as Monad +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Ord (comparing) +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Folds" + [ testGroup "Folding" + [ testProperty "prop_foldl" prop_foldl + , testProperty "prop_foldl1" prop_foldl1 + , testProperty "prop_foldl'" prop_foldl' + , testProperty "prop_foldl1'" prop_foldl1' + , testProperty "prop_foldr" prop_foldr + , testProperty "prop_foldr1" prop_foldr1 + , testProperty "prop_foldr'" prop_foldr' + , testProperty "prop_foldr1'" prop_foldr1' + , testProperty "prop_ifoldl" prop_ifoldl + , testProperty "prop_ifoldl'" prop_ifoldl' + , testProperty "prop_ifoldr" prop_ifoldr + , testProperty "prop_ifoldr'" prop_ifoldr' + ] + , testGroup "Specialized folds" + [ testProperty "prop_all" prop_all + , testProperty "prop_any" prop_any + , testProperty "prop_and" prop_and + , testProperty "prop_or" prop_or + , testProperty "prop_sum" prop_sum + , testProperty "prop_product" prop_product + , testProperty "prop_maximum" prop_maximum + , testProperty "prop_maximumBy" prop_maximumBy + , testProperty "prop_minimum" prop_minimum + , testProperty "prop_minimumBy" prop_minimumBy + , testProperty "prop_maxIndex" prop_maxIndex + , testProperty "prop_maxIndexBy" prop_maxIndexBy + , testProperty "prop_minIndex" prop_minIndex + , testProperty "prop_minIndexBy" prop_minIndexBy + ] + , testGroup "Monadic folds" + [ testProperty "prop_foldM" prop_foldM + , testProperty "prop_foldM'" prop_foldM' + , testProperty "prop_fold1M" prop_fold1M + , testProperty "prop_fold1M'" prop_fold1M' + , testProperty "prop_foldM_" prop_foldM_ + , testProperty "prop_foldM'_" prop_foldM'_ + , testProperty "prop_fold1M_" prop_fold1M_ + , testProperty "prop_fold1M'_" prop_fold1M'_ + , testProperty "prop_ifoldM" prop_ifoldM + , testProperty "prop_ifoldM'" prop_ifoldM' + , testProperty "prop_ifoldM_" prop_ifoldM_ + , testProperty "prop_ifoldM'_" prop_ifoldM'_ + ] + , testGroup "Monadic sequencing" + [ testProperty "prop_sequence" prop_sequence + , testProperty "prop_sequence_short_circuits" prop_sequence_short_circuits + , testProperty "prop_sequence_" prop_sequence_ + ] + ] + +type V = NonEmptyVector Int + +-- ---------------------------------------------------------------------- -- +-- Models + +indexedList :: V -> [(Int, Int)] +indexedList = List.zip [0 ..] . elems + +-- | Ties resolve to the first occurrence, matching @vector@. +-- +firstBy :: (a -> a -> Bool) -> [(Int, a)] -> (Int, a) +firstBy better = List.foldl1 (\x y -> if better (snd y) (snd x) then y else x) + +-- | A comparison with many ties, so that tie-breaking is exercised. +-- +coarse :: Int -> Int -> Ordering +coarse = comparing (`mod` 3) + +-- | A writer-style step that logs the accumulator and element it consumes, +-- exposing how the accumulator is threaded even when the result is +-- discarded. +-- +step :: (Int -> Int -> Int) -> Int -> Int -> ([(Int, Int)], Int) +step f acc a = logged (acc, a) (f acc a) + +-- | A writer-style indexed step that logs the accumulator and index it +-- consumes. +-- +istep + :: (Int -> Int -> Int -> Int) + -> Int + -> Int + -> Int + -> ([(Int, Int)], Int) +istep f acc i a = logged (acc, i) (f acc i a) + +-- ---------------------------------------------------------------------- -- +-- Folding + +prop_foldl :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldl (Fn2 f) z v = NEV.foldl f z v === List.foldl f z (elems v) + +prop_foldl1 :: Fun (Int, Int) Int -> V -> Property +prop_foldl1 (Fn2 f) v = NEV.foldl1 f v === foldl1 f (elems1 v) + +prop_foldl' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldl' (Fn2 f) z v = NEV.foldl' f z v === List.foldl f z (elems v) + +prop_foldl1' :: Fun (Int, Int) Int -> V -> Property +prop_foldl1' (Fn2 f) v = NEV.foldl1' f v === foldl1 f (elems1 v) + +prop_foldr :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldr (Fn2 f) z v = NEV.foldr f z v === List.foldr f z (elems v) + +prop_foldr1 :: Fun (Int, Int) Int -> V -> Property +prop_foldr1 (Fn2 f) v = NEV.foldr1 f v === foldr1 f (elems1 v) + +prop_foldr' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldr' (Fn2 f) z v = NEV.foldr' f z v === List.foldr f z (elems v) + +prop_foldr1' :: Fun (Int, Int) Int -> V -> Property +prop_foldr1' (Fn2 f) v = NEV.foldr1' f v === foldr1 f (elems1 v) + +prop_ifoldl :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldl (Fn3 f) z v = + NEV.ifoldl f z v + === List.foldl (\acc (i, a) -> f acc i a) z (indexedList v) + +prop_ifoldl' :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldl' (Fn3 f) z v = + NEV.ifoldl' f z v + === List.foldl (\acc (i, a) -> f acc i a) z (indexedList v) + +prop_ifoldr :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldr (Fn3 f) z v = + NEV.ifoldr f z v + === List.foldr (\(i, a) acc -> f i a acc) z (indexedList v) + +prop_ifoldr' :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldr' (Fn3 f) z v = + NEV.ifoldr' f z v + === List.foldr (\(i, a) acc -> f i a acc) z (indexedList v) + +-- ---------------------------------------------------------------------- -- +-- Specialized folds + +prop_all :: Fun Int Bool -> V -> Property +prop_all (Fn p) v = NEV.all p v === List.all p (elems v) + +prop_any :: Fun Int Bool -> V -> Property +prop_any (Fn p) v = NEV.any p v === List.any p (elems v) + +prop_and :: NonEmptyVector Bool -> Property +prop_and v = NEV.and v === List.and (elems v) + +prop_or :: NonEmptyVector Bool -> Property +prop_or v = NEV.or v === List.or (elems v) + +prop_sum :: V -> Property +prop_sum v = NEV.sum v === List.sum (elems v) + +prop_product :: V -> Property +prop_product v = NEV.product v === List.product (elems v) + +prop_maximum :: V -> Property +prop_maximum v = NEV.maximum v === maximum (elems1 v) + +prop_maximumBy :: V -> Property +prop_maximumBy v = + NEV.maximumBy coarse v + === snd (firstBy (\a b -> coarse a b == GT) (indexedList v)) + +prop_minimum :: V -> Property +prop_minimum v = NEV.minimum v === minimum (elems1 v) + +prop_minimumBy :: V -> Property +prop_minimumBy v = + NEV.minimumBy coarse v + === snd (firstBy (\a b -> coarse a b == LT) (indexedList v)) + +prop_maxIndex :: V -> Property +prop_maxIndex v = + NEV.maxIndex w === fst (firstBy (>) (indexedList w)) + where + w = vec (List.map (`mod` 4) (elems v)) + +prop_maxIndexBy :: V -> Property +prop_maxIndexBy v = + NEV.maxIndexBy coarse v + === fst (firstBy (\a b -> coarse a b == GT) (indexedList v)) + +prop_minIndex :: V -> Property +prop_minIndex v = + NEV.minIndex w === fst (firstBy (<) (indexedList w)) + where + w = vec (List.map (`mod` 4) (elems v)) + +prop_minIndexBy :: V -> Property +prop_minIndexBy v = + NEV.minIndexBy coarse v + === fst (firstBy (\a b -> coarse a b == LT) (indexedList v)) + +-- ---------------------------------------------------------------------- -- +-- Monadic folds + +prop_foldM :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldM (Fn2 f) z v = + NEV.foldM (step f) z v === Monad.foldM (step f) z (elems v) + +prop_foldM' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldM' (Fn2 f) z v = + NEV.foldM' (step f) z v === Monad.foldM (step f) z (elems v) + +prop_fold1M :: Fun (Int, Int) Int -> V -> Property +prop_fold1M (Fn2 f) v = + NEV.fold1M (step f) v === Monad.foldM (step f) a as + where + a :| as = elems1 v + +prop_fold1M' :: Fun (Int, Int) Int -> V -> Property +prop_fold1M' (Fn2 f) v = + NEV.fold1M' (step f) v === Monad.foldM (step f) a as + where + a :| as = elems1 v + +prop_foldM_ :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldM_ (Fn2 f) z v = + NEV.foldM_ (step f) z v === Monad.foldM_ (step f) z (elems v) + +prop_foldM'_ :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldM'_ (Fn2 f) z v = + NEV.foldM'_ (step f) z v === Monad.foldM_ (step f) z (elems v) + +prop_fold1M_ :: Fun (Int, Int) Int -> V -> Property +prop_fold1M_ (Fn2 f) v = + NEV.fold1M_ (step f) v === Monad.foldM_ (step f) a as + where + a :| as = elems1 v + +prop_fold1M'_ :: Fun (Int, Int) Int -> V -> Property +prop_fold1M'_ (Fn2 f) v = + NEV.fold1M'_ (step f) v === Monad.foldM_ (step f) a as + where + a :| as = elems1 v + +prop_ifoldM :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldM (Fn3 f) z v = + NEV.ifoldM (istep f) z v + === Monad.foldM (\acc (i, a) -> istep f acc i a) z (indexedList v) + +prop_ifoldM' :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldM' (Fn3 f) z v = + NEV.ifoldM' (istep f) z v + === Monad.foldM (\acc (i, a) -> istep f acc i a) z (indexedList v) + +prop_ifoldM_ :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldM_ (Fn3 f) z v = + NEV.ifoldM_ (istep f) z v + === Monad.foldM_ (\acc (i, a) -> istep f acc i a) z (indexedList v) + +prop_ifoldM'_ :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_ifoldM'_ (Fn3 f) z v = + NEV.ifoldM'_ (istep f) z v + === Monad.foldM_ (\acc (i, a) -> istep f acc i a) z (indexedList v) + +-- ---------------------------------------------------------------------- -- +-- Monadic sequencing + +prop_sequence :: NonEmptyVector (Int, Int) -> Property +prop_sequence v = + fmap elems (NEV.sequence (vec (List.map (uncurry logged) (elems v)))) + === List.unzip (elems v) + +prop_sequence_short_circuits :: V -> Property +prop_sequence_short_circuits v = forAll (genIndex v) $ \i -> + let ms = List.map Just (elems v) + in fmap elems (NEV.sequence (vec ms)) === Just (elems v) + .&&. NEV.sequence (vec (adjustAt i (const Nothing) ms)) === Nothing + +prop_sequence_ :: NonEmptyVector (Int, Int) -> Property +prop_sequence_ v = + NEV.sequence_ (vec (List.map (uncurry logged) (elems v))) + === (List.map fst (elems v), ()) diff --git a/test/Test/Data/Vector/NonEmpty/Grouping.hs b/test/Test/Data/Vector/NonEmpty/Grouping.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Grouping.hs @@ -0,0 +1,106 @@ +module Test.Data.Vector.NonEmpty.Grouping +( tests +) where + + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Grouping" + [ testGroup "group" + [ testProperty "prop_group" prop_group + , testProperty "prop_group_singleton" prop_group_singleton + , testProperty "prop_group_all_equal" prop_group_all_equal + , testProperty "prop_group_distinct" prop_group_distinct + , testProperty "prop_group_runs" prop_group_runs + ] + , testGroup "groupBy" + [ testProperty "prop_groupBy" prop_groupBy + , testProperty "prop_groupBy_singleton" prop_groupBy_singleton + , testProperty "prop_groupBy_all_true" prop_groupBy_all_true + , testProperty "prop_groupBy_all_false" prop_groupBy_all_false + , testProperty "prop_groupBy_equivalence" prop_groupBy_equivalence + , testProperty "prop_groupBy_nontransitive" prop_groupBy_nontransitive + , testProperty "prop_groupBy_asymmetric" prop_groupBy_asymmetric + ] + ] + +groupElems :: NonEmpty.NonEmpty (NonEmptyVector element) -> [[element]] +groupElems = List.map elems . NonEmpty.toList + +prop_group :: NonEmptyVector Int -> Property +prop_group input = + groupElems (NEV.group (vec values)) === List.group values + where + values = List.map (`mod` 4) (elems input) + +prop_group_singleton :: Int -> Property +prop_group_singleton value = + groupElems (NEV.group (vec [value])) === [[value]] + +prop_group_all_equal :: Int -> Positive Int -> Property +prop_group_all_equal value (Positive count) = + groupElems (NEV.group (vec values)) === [values] + where + values = List.replicate count value + +prop_group_distinct :: NonEmptyVector Int -> Property +prop_group_distinct input = + groupElems (NEV.group (vec values)) === List.map (: []) values + where + values = List.nub (elems input) + +prop_group_runs :: Property +prop_group_runs = once $ + groupElems (NEV.group (vec "Mississippi")) + === ["M", "i", "ss", "i", "ss", "i", "pp", "i"] + +prop_groupBy :: Fun (Int, Int) Bool -> NonEmptyVector Int -> Property +prop_groupBy (Fn2 predicate) input = + groupElems (NEV.groupBy predicate (vec values)) + === List.groupBy predicate values + where + values = List.map (`mod` 4) (elems input) + +prop_groupBy_singleton :: Int -> Property +prop_groupBy_singleton value = + groupElems (NEV.groupBy predicate (vec [value])) === [[value]] + where + predicate _ _ = error "groupBy evaluated its predicate on a singleton" + +prop_groupBy_all_true :: NonEmptyVector Int -> Property +prop_groupBy_all_true input = + groupElems (NEV.groupBy (\_ _ -> True) input) === [elems input] + +prop_groupBy_all_false :: NonEmptyVector Int -> Property +prop_groupBy_all_false input = + groupElems (NEV.groupBy (\_ _ -> False) input) + === List.map (: []) (elems input) + +prop_groupBy_equivalence :: NonEmptyVector Int -> Property +prop_groupBy_equivalence input = + groupElems (NEV.groupBy sameParity input) + === List.groupBy sameParity (elems input) + where + sameParity first second = even first == even second + +prop_groupBy_nontransitive :: Property +prop_groupBy_nontransitive = once $ + groupElems (NEV.groupBy nearby (vec [1, 2, 3, 4] :: NonEmptyVector Int)) + === [[1, 2], [3, 4]] + where + nearby first second = abs (first - second) <= 1 + +prop_groupBy_asymmetric :: Property +prop_groupBy_asymmetric = once $ + groupElems (NEV.groupBy (<) (vec [1, 2, 1, 3, 0, 4] :: NonEmptyVector Int)) + === [[1, 2], [1, 3], [0, 4]] diff --git a/test/Test/Data/Vector/NonEmpty/Instances.hs b/test/Test/Data/Vector/NonEmpty/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Instances.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Test.Data.Vector.NonEmpty.Instances +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Laws and list models for the type class instances of t'NonEmptyVector'. +-- +module Test.Data.Vector.NonEmpty.Instances +( tests +) where + + +import qualified Control.Applicative as Applicative +import Control.DeepSeq (rnf) +import Control.Exception (evaluate) +import Control.Monad.Zip (munzip, mzip, mzipWith) + +import Data.Data (gmapM, gmapQ, gmapT, showConstr, toConstr) +import qualified Data.Foldable as Foldable +#if MIN_VERSION_base(4,18,0) +import qualified Data.Foldable1 as Foldable1 +#endif +import Data.Functor.Classes (liftCompare, liftEq, readsPrec1, showsPrec1) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity(..)) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Ord (comparing) +import Data.Semigroup (sconcat, stimes) +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Text.Read (readMaybe) + + +tests :: TestTree +tests = testGroup "Instances" + [ testGroup "Eq" + [ testProperty "prop_eq" prop_eq + , testProperty "prop_liftEq" prop_liftEq + ] + , testGroup "Ord" + [ testProperty "prop_compare" prop_compare + , testProperty "prop_liftCompare" prop_liftCompare + ] + , testGroup "Show" + [ testProperty "prop_show" prop_show + , testProperty "prop_showsPrec" prop_showsPrec + , testProperty "prop_showsPrec1" prop_showsPrec1 + ] + , testGroup "Read" + [ testProperty "prop_read_show" prop_read_show + , testProperty "prop_read_list" prop_read_list + , testProperty "prop_readsPrec1" prop_readsPrec1 + ] + , testGroup "Functor" + [ testProperty "prop_fmap" prop_fmap + , testProperty "prop_functor_identity" prop_functor_identity + , testProperty "prop_functor_composition" prop_functor_composition + ] + , testGroup "Applicative" + [ testProperty "prop_pure" prop_pure + , testProperty "prop_ap" prop_ap + , testProperty "prop_liftA2" prop_liftA2 + , testProperty "prop_then" prop_then + , testProperty "prop_before" prop_before + , testProperty "prop_applicative_identity" prop_applicative_identity + , testProperty "prop_applicative_homomorphism" prop_applicative_homomorphism + , testProperty "prop_applicative_interchange" prop_applicative_interchange + , testProperty "prop_applicative_composition" prop_applicative_composition + ] + , testGroup "Monad" + [ testProperty "prop_bind" prop_bind + , testProperty "prop_monad_left_identity" prop_monad_left_identity + , testProperty "prop_monad_right_identity" prop_monad_right_identity + , testProperty "prop_monad_associativity" prop_monad_associativity + ] + , testGroup "MonadZip" + [ testProperty "prop_mzip" prop_mzip + , testProperty "prop_mzipWith" prop_mzipWith + , testProperty "prop_munzip" prop_munzip + , testProperty "prop_monadzip_information" prop_monadzip_information + ] + , testGroup "Semigroup" + [ testProperty "prop_append" prop_append + , testProperty "prop_semigroup_associativity" prop_semigroup_associativity + , testProperty "prop_sconcat" prop_sconcat + , testProperty "prop_stimes" prop_stimes + , testProperty "prop_stimes_non_positive" prop_stimes_non_positive + ] + , testGroup "Foldable" + [ testProperty "prop_foldable_toList" prop_foldable_toList + , testProperty "prop_foldable_foldMap" prop_foldable_foldMap + , testProperty "prop_foldable_foldr" prop_foldable_foldr + , testProperty "prop_foldable_foldl" prop_foldable_foldl + , testProperty "prop_foldable_length" prop_foldable_length + , testProperty "prop_foldable_null" prop_foldable_null + , testProperty "prop_foldable_elem" prop_foldable_elem + , testProperty "prop_foldable_sum_product" prop_foldable_sum_product + , testProperty "prop_foldable_maximum_minimum" prop_foldable_maximum_minimum + ] +#if MIN_VERSION_base(4,18,0) + , testGroup "Foldable1" + [ testProperty "prop_foldable1_foldMap1" prop_foldable1_foldMap1 + , testProperty "prop_foldable1_foldMap1'" prop_foldable1_foldMap1' + , testProperty "prop_foldable1_fold1" prop_foldable1_fold1 + , testProperty "prop_foldable1_toNonEmpty" prop_foldable1_toNonEmpty + , testProperty "prop_foldable1_head_last" prop_foldable1_head_last + , testProperty "prop_foldable1_maximum_minimum" prop_foldable1_maximum_minimum + , testProperty "prop_foldable1_foldrMap1" prop_foldable1_foldrMap1 + , testProperty "prop_foldable1_foldlMap1" prop_foldable1_foldlMap1 + ] +#endif + , testGroup "Traversable" + [ testProperty "prop_traverse" prop_traverse + , testProperty "prop_sequenceA" prop_sequenceA + , testProperty "prop_traversable_identity" prop_traversable_identity + , testProperty "prop_traversable_composition" prop_traversable_composition + ] + , testGroup "NFData" + [ testProperty "prop_rnf" prop_rnf + , testProperty "prop_rnf_forces_elements" prop_rnf_forces_elements + ] + , testGroup "Data" + [ testProperty "prop_data" prop_data + ] + ] + +type V = NonEmptyVector Int + +-- | Either the same vector or an unrelated one, so that equal pairs are +-- generated often. +-- +genNear :: V -> Gen V +genNear v = oneof [pure v, arbitrary] + +-- ---------------------------------------------------------------------- -- +-- Eq and Ord + +prop_eq :: V -> Property +prop_eq v = forAll (genNear v) $ \w -> (v == w) === (elems v == elems w) + +prop_liftEq :: V -> Property +prop_liftEq v = forAll (genNear v) $ \w -> + liftEq eqMod3 v w === liftEq eqMod3 (elems v) (elems w) + where + eqMod3 a b = a `mod` 3 == b `mod` 3 + +prop_compare :: V -> Property +prop_compare v = forAll (genNear v) $ \w -> + compare v w === compare (elems v) (elems w) + +prop_liftCompare :: V -> Property +prop_liftCompare v = forAll (genNear v) $ \w -> + liftCompare cmp v w === liftCompare cmp (elems v) (elems w) + where + cmp = comparing (`mod` 3) + +-- ---------------------------------------------------------------------- -- +-- Show and Read + +prop_show :: V -> Property +prop_show v = show v === show (elems v) + +prop_showsPrec :: Int -> V -> String -> Property +prop_showsPrec d v s = showsPrec d v s === show (elems v) ++ s + +prop_showsPrec1 :: Int -> V -> String -> Property +prop_showsPrec1 d v s = showsPrec1 d v s === showsPrec1 d (elems v) s + +prop_read_show :: V -> Property +prop_read_show v = read (show v) === v + +-- The empty list must not parse. +prop_read_list :: [Int] -> Property +prop_read_list as = + fmap elems (readMaybe (show as) :: Maybe V) === whenNonEmpty as + +prop_readsPrec1 :: [Int] -> Property +prop_readsPrec1 as = + [ (elems v, rest) | (v, rest) <- readsPrec1 0 (show as) :: [(V, String)] ] + === [ (as, "") | not (List.null as) ] + +-- ---------------------------------------------------------------------- -- +-- Functor + +prop_fmap :: Fun Int Int -> V -> Property +prop_fmap (Fn f) v = elems (fmap f v) === List.map f (elems v) + +prop_functor_identity :: V -> Property +prop_functor_identity v = fmap id v === v + +prop_functor_composition :: Fun Int Int -> Fun Int Int -> V -> Property +prop_functor_composition (Fn f) (Fn g) v = + fmap (f . g) v === (fmap f . fmap g) v + +-- ---------------------------------------------------------------------- -- +-- Applicative +-- +-- '<*>' and '>>=' multiply sizes, so laws chaining several of them run on +-- small inputs. + +prop_pure :: Int -> Property +prop_pure a = elems (pure a :: V) === [a] + +prop_ap :: NonEmptyVector (Fun Int Int) -> V -> Property +prop_ap fs v = + elems (fmap applyFun fs <*> v) + === (List.map applyFun (elems fs) <*> elems v) + +prop_liftA2 :: Fun (Int, Int) Int -> V -> V -> Property +prop_liftA2 (Fn2 f) v w = + elems (Applicative.liftA2 f v w) + === Applicative.liftA2 f (elems v) (elems w) + +prop_then :: V -> V -> Property +prop_then v w = elems (v *> w) === (elems v *> elems w) + +prop_before :: V -> V -> Property +prop_before v w = elems (v <* w) === (elems v <* elems w) + +prop_applicative_identity :: V -> Property +prop_applicative_identity v = (pure id <*> v) === v + +prop_applicative_homomorphism :: Fun Int Int -> Int -> Property +prop_applicative_homomorphism (Fn f) a = (pure f <*> pure a) === (pure (f a) :: V) + +prop_applicative_interchange :: NonEmptyVector (Fun Int Int) -> Int -> Property +prop_applicative_interchange fs a = (u <*> pure a) === (pure ($ a) <*> u) + where + u = fmap applyFun fs + +prop_applicative_composition :: Property +prop_applicative_composition = forAll (resize 10 arbitrary) $ \(fs, gs, w) -> + let u = fmap applyFun (fs :: NonEmptyVector (Fun Int Int)) + v = fmap applyFun (gs :: NonEmptyVector (Fun Int Int)) + in (pure (.) <*> u <*> v <*> (w :: V)) === (u <*> (v <*> w)) + +-- ---------------------------------------------------------------------- -- +-- Monad + +prop_bind :: V -> Fun Int V -> Property +prop_bind v (Fn f) = elems (v >>= f) === (elems v >>= elems . f) + +prop_monad_left_identity :: Int -> Fun Int V -> Property +prop_monad_left_identity a (Fn f) = (pure a >>= f) === f a + +prop_monad_right_identity :: V -> Property +prop_monad_right_identity v = (v >>= pure) === v + +prop_monad_associativity :: Property +prop_monad_associativity = forAll (resize 10 arbitrary) $ \(v, Fn f, Fn g) -> + ((v :: V) >>= f >>= g) === (v >>= (\a -> f a >>= (g :: Int -> V))) + +-- ---------------------------------------------------------------------- -- +-- MonadZip + +prop_mzip :: V -> V -> Property +prop_mzip v w = elems (mzip v w) === List.zip (elems v) (elems w) + +prop_mzipWith :: Fun (Int, Int) Int -> V -> V -> Property +prop_mzipWith (Fn2 f) v w = + elems (mzipWith f v w) === List.zipWith f (elems v) (elems w) + +prop_munzip :: NonEmptyVector (Int, Int) -> Property +prop_munzip v = (elems a, elems b) === List.unzip (elems v) + where + (a, b) = munzip v + +-- Zipping vectors of equal shape loses no information. +prop_monadzip_information :: Fun Int Int -> V -> Property +prop_monadzip_information (Fn f) v = munzip (mzip v w) === (v, w) + where + w = fmap f v + +-- ---------------------------------------------------------------------- -- +-- Semigroup + +prop_append :: V -> V -> Property +prop_append v w = elems (v <> w) === elems v ++ elems w + +prop_semigroup_associativity :: V -> V -> V -> Property +prop_semigroup_associativity u v w = ((u <> v) <> w) === (u <> (v <> w)) + +prop_sconcat :: V -> [V] -> Property +prop_sconcat v vs = elems (sconcat (v :| vs)) === List.concatMap elems (v : vs) + +prop_stimes :: V -> Property +prop_stimes v = forAll (choose (1, 5)) $ \n -> + elems (stimes (n :: Int) v) === List.concat (List.replicate n (elems v)) + +-- A non-positive multiplier would produce an empty vector, so it must throw. +prop_stimes_non_positive :: V -> Property +prop_stimes_non_positive v = forAll (choose (-5, 0)) $ \n -> + throws (stimes (n :: Int) v) + +-- ---------------------------------------------------------------------- -- +-- Foldable +-- +-- Order-sensitive monoids and fold functions pin down traversal order. + +prop_foldable_toList :: V -> Property +prop_foldable_toList v = Foldable.toList v === elems v + +prop_foldable_foldMap :: Fun Int [Int] -> V -> Property +prop_foldable_foldMap (Fn f) v = Foldable.foldMap f v === Foldable.foldMap f (elems v) + +prop_foldable_foldr :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldable_foldr (Fn2 f) z v = + Foldable.foldr f z v === Foldable.foldr f z (elems v) + +prop_foldable_foldl :: Fun (Int, Int) Int -> Int -> V -> Property +prop_foldable_foldl (Fn2 f) z v = + Foldable.foldl f z v === Foldable.foldl f z (elems v) + +prop_foldable_length :: V -> Property +prop_foldable_length v = Foldable.length v === List.length (elems v) + +prop_foldable_null :: V -> Property +prop_foldable_null v = Foldable.null v === False + +prop_foldable_elem :: Int -> V -> Property +prop_foldable_elem a v = + Foldable.elem (a `mod` 4) w === Foldable.elem (a `mod` 4) (elems w) + where + w = vec (List.map (`mod` 4) (elems v)) + +prop_foldable_sum_product :: V -> Property +prop_foldable_sum_product v = + (Foldable.sum v, Foldable.product v) + === (Foldable.sum (elems v), Foldable.product (elems v)) + +prop_foldable_maximum_minimum :: V -> Property +prop_foldable_maximum_minimum v = + (Foldable.maximum v, Foldable.minimum v) + === (Foldable.maximum (elems1 v), Foldable.minimum (elems1 v)) + +-- ---------------------------------------------------------------------- -- +-- Foldable1 +-- +-- The instance for non-empty lists serves as the model. + +#if MIN_VERSION_base(4,18,0) +prop_foldable1_foldMap1 :: Fun Int [Int] -> V -> Property +prop_foldable1_foldMap1 (Fn f) v = + Foldable1.foldMap1 f v === Foldable1.foldMap1 f (elems1 v) + +prop_foldable1_foldMap1' :: Fun Int [Int] -> V -> Property +prop_foldable1_foldMap1' (Fn f) v = + Foldable1.foldMap1' f v === Foldable1.foldMap1' f (elems1 v) + +prop_foldable1_fold1 :: NonEmptyVector [Int] -> Property +prop_foldable1_fold1 v = Foldable1.fold1 v === Foldable1.fold1 (elems1 v) + +prop_foldable1_toNonEmpty :: V -> Property +prop_foldable1_toNonEmpty v = Foldable1.toNonEmpty v === elems1 v + +prop_foldable1_head_last :: V -> Property +prop_foldable1_head_last v = + (Foldable1.head v, Foldable1.last v) + === (Foldable1.head (elems1 v), Foldable1.last (elems1 v)) + +prop_foldable1_maximum_minimum :: V -> Property +prop_foldable1_maximum_minimum v = + (Foldable1.maximum v, Foldable1.minimum v) + === (Foldable1.maximum (elems1 v), Foldable1.minimum (elems1 v)) + +prop_foldable1_foldrMap1 :: Fun Int Int -> Fun (Int, Int) Int -> V -> Property +prop_foldable1_foldrMap1 (Fn f) (Fn2 g) v = + (Foldable1.foldrMap1 f g v, Foldable1.foldrMap1' f g v) + === ( Foldable1.foldrMap1 f g (elems1 v) + , Foldable1.foldrMap1' f g (elems1 v) + ) + +prop_foldable1_foldlMap1 :: Fun Int Int -> Fun (Int, Int) Int -> V -> Property +prop_foldable1_foldlMap1 (Fn f) (Fn2 g) v = + (Foldable1.foldlMap1 f g v, Foldable1.foldlMap1' f g v) + === ( Foldable1.foldlMap1 f g (elems1 v) + , Foldable1.foldlMap1' f g (elems1 v) + ) +#endif + +-- ---------------------------------------------------------------------- -- +-- Traversable + +prop_traverse :: Fun Int Int -> V -> Property +prop_traverse (Fn f) v = + fmap elems (traverse (\a -> logged a (f a)) v) + === traverse (\a -> logged a (f a)) (elems v) + +prop_sequenceA :: NonEmptyVector ([Int], Int) -> Property +prop_sequenceA v = fmap elems (sequenceA v) === sequenceA (elems v) + +prop_traversable_identity :: V -> Property +prop_traversable_identity v = traverse Identity v === Identity v + +prop_traversable_composition + :: Fun Int (Maybe Int) + -> Fun Int ([Int], Int) + -> V + -> Property +prop_traversable_composition (Fn f) (Fn g) v = + traverse (Compose . fmap g . f) v + === (Compose . fmap (traverse g) . traverse f) v + +-- ---------------------------------------------------------------------- -- +-- NFData + +prop_rnf :: V -> Property +prop_rnf v = rnf v === () + +prop_rnf_forces_elements :: Property +prop_rnf_forces_elements = once $ + throwsIO (evaluate (rnf (NEV.singleton (error "unforced element" :: Int)))) + +-- ---------------------------------------------------------------------- -- +-- Data + +-- The representation is a single constructor wrapping a single field. +prop_data :: V -> Property +prop_data v = + gmapT id v === v + .&&. gmapM Just v === Just v + .&&. gmapQ (const ()) v === [()] + .&&. showConstr (toConstr v) === "NonEmptyVector" diff --git a/test/Test/Data/Vector/NonEmpty/Modification.hs b/test/Test/Data/Vector/NonEmpty/Modification.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Modification.hs @@ -0,0 +1,184 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Modification +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for bulk updates, accumulations, permutations, and safe +-- destructive updates. +-- +module Test.Data.Vector.NonEmpty.Modification +( tests +) where + + +import qualified Data.List as List +import Data.Maybe (mapMaybe) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Modification" + [ testGroup "Bulk updates" + [ testProperty "prop_bulk_update" prop_bulk_update + , testProperty "prop_bulk_update_out_of_bounds" prop_bulk_update_out_of_bounds + , testProperty "prop_update" prop_update + , testProperty "prop_update_" prop_update_ + , testProperty "prop_unsafeUpd" prop_unsafeUpd + , testProperty "prop_unsafeUpdate" prop_unsafeUpdate + , testProperty "prop_unsafeUpdate_" prop_unsafeUpdate_ + ] + , testGroup "Accumulations" + [ testProperty "prop_accum" prop_accum + , testProperty "prop_accum_out_of_bounds" prop_accum_out_of_bounds + , testProperty "prop_accumulate" prop_accumulate + , testProperty "prop_accumulate_" prop_accumulate_ + , testProperty "prop_unsafeAccum" prop_unsafeAccum + , testProperty "prop_unsafeAccumulate" prop_unsafeAccumulate + , testProperty "prop_unsafeAccumulate_" prop_unsafeAccumulate_ + ] + , testGroup "Permutations" + [ testProperty "prop_reverse" prop_reverse + , testProperty "prop_reverse_involutive" prop_reverse_involutive + , testProperty "prop_backpermute" prop_backpermute + , testProperty "prop_backpermute_out_of_bounds" prop_backpermute_out_of_bounds + , testProperty "prop_unsafeBackpermute" prop_unsafeBackpermute + ] + , testGroup "Safe destructive updates" + [ testProperty "prop_modify" prop_modify + , testProperty "prop_modify_preserves_input" prop_modify_preserves_input + ] + ] + +-- ---------------------------------------------------------------------- -- +-- Models + +-- | Later updates to the same index win. +-- +updateList :: [(Int, a)] -> [a] -> [a] +updateList us as = List.foldl' (\acc (i, a) -> adjustAt i (const a) acc) as us + +accumList :: (a -> b -> a) -> [(Int, b)] -> [a] -> [a] +accumList f us as = List.foldl' (\acc (i, b) -> adjustAt i (`f` b) acc) as us + +-- ---------------------------------------------------------------------- -- +-- Bulk updates + +prop_bulk_update :: NonEmptyVector Int -> Property +prop_bulk_update v = forAll (genUpdates v) $ \us -> + elems (v NEV.// us) === updateList us (elems v) + +prop_bulk_update_out_of_bounds :: NonEmptyVector Int -> Int -> Property +prop_bulk_update_out_of_bounds v a = forAll (genOutOfBounds v) $ \i -> + throws (v NEV.// [(i, a)]) + +prop_update :: NonEmptyVector Int -> Property +prop_update v = forAll (genUpdates v) $ \us -> + elems (NEV.update v (V.fromList us)) === updateList us (elems v) + +-- Surplus values beyond the index vector are ignored. +prop_update_ :: NonEmptyVector Int -> [Int] -> Property +prop_update_ v surplus = forAll (genUpdates v) $ \us -> + let (is, as) = List.unzip us + in elems (NEV.update_ v (V.fromList is) (V.fromList (as ++ surplus))) + === updateList us (elems v) + +prop_unsafeUpd :: NonEmptyVector Int -> Property +prop_unsafeUpd v = forAll (genUpdates v) $ \us -> + elems (NEV.unsafeUpd v us) === updateList us (elems v) + +prop_unsafeUpdate :: NonEmptyVector Int -> Property +prop_unsafeUpdate v = forAll (genUpdates v) $ \us -> + elems (NEV.unsafeUpdate v (V.fromList us)) === updateList us (elems v) + +prop_unsafeUpdate_ :: NonEmptyVector Int -> Property +prop_unsafeUpdate_ v = forAll (genUpdates v) $ \us -> + let (is, as) = List.unzip us + in elems (NEV.unsafeUpdate_ v (V.fromList is) (V.fromList as)) + === updateList us (elems v) + +-- ---------------------------------------------------------------------- -- +-- Accumulations + +prop_accum :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_accum (Fn2 f) v = forAll (genUpdates v) $ \us -> + elems (NEV.accum f v us) === accumList f us (elems v) + +prop_accum_out_of_bounds :: NonEmptyVector Int -> Int -> Property +prop_accum_out_of_bounds v b = forAll (genOutOfBounds v) $ \i -> + throws (NEV.accum (+) v [(i, b)]) + +prop_accumulate :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_accumulate (Fn2 f) v = forAll (genUpdates v) $ \us -> + elems (NEV.accumulate f v (V.fromList us)) === accumList f us (elems v) + +prop_accumulate_ :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_accumulate_ (Fn2 f) v = forAll (genUpdates v) $ \us -> + let (is, bs) = List.unzip us + in elems (NEV.accumulate_ f v (V.fromList is) (V.fromList bs)) + === accumList f us (elems v) + +prop_unsafeAccum :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_unsafeAccum (Fn2 f) v = forAll (genUpdates v) $ \us -> + elems (NEV.unsafeAccum f v us) === accumList f us (elems v) + +prop_unsafeAccumulate :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_unsafeAccumulate (Fn2 f) v = forAll (genUpdates v) $ \us -> + elems (NEV.unsafeAccumulate f v (V.fromList us)) + === accumList f us (elems v) + +prop_unsafeAccumulate_ :: Fun (Int, Int) Int -> NonEmptyVector Int -> Property +prop_unsafeAccumulate_ (Fn2 f) v = forAll (genUpdates v) $ \us -> + let (is, bs) = List.unzip us + in elems (NEV.unsafeAccumulate_ f v (V.fromList is) (V.fromList bs)) + === accumList f us (elems v) + +-- ---------------------------------------------------------------------- -- +-- Permutations + +prop_reverse :: NonEmptyVector Int -> Property +prop_reverse v = elems (NEV.reverse v) === List.reverse (elems v) + +prop_reverse_involutive :: NonEmptyVector Int -> Property +prop_reverse_involutive v = NEV.reverse (NEV.reverse v) === v + +prop_backpermute :: NonEmptyVector Int -> Property +prop_backpermute v = forAll (genIndices v) $ \is -> + elems (NEV.backpermute v is) + === mapMaybe (`lookupList` elems v) (elems is) + +prop_backpermute_out_of_bounds :: NonEmptyVector Int -> Property +prop_backpermute_out_of_bounds v = forAll (genOutOfBounds v) $ \i -> + throws (NEV.backpermute v (NEV.singleton i)) + +prop_unsafeBackpermute :: NonEmptyVector Int -> Property +prop_unsafeBackpermute v = forAll (genIndices v) $ \is -> + elems (NEV.unsafeBackpermute v is) + === mapMaybe (`lookupList` elems v) (elems is) + +-- ---------------------------------------------------------------------- -- +-- Safe destructive updates + +prop_modify :: NonEmptyVector Int -> Int -> Property +prop_modify v a = forAll ((,) <$> genIndex v <*> genIndex v) $ \(i, j) -> + elems (NEV.modify (\mv -> MV.write mv i a >> MV.swap mv i j) v) + === swapAt i j (adjustAt i (const a) (elems v)) + +-- The input vector is copied, never mutated in place. +prop_modify_preserves_input :: NonEmptyList Int -> Int -> Property +prop_modify_preserves_input (NonEmpty as) a = + (elems w, elems v) === (List.map (const a) as, as) + where + v = vec as + w = NEV.modify (`MV.set` a) v diff --git a/test/Test/Data/Vector/NonEmpty/Mutable.hs b/test/Test/Data/Vector/NonEmpty/Mutable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Mutable.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Test.Data.Vector.NonEmpty.Mutable +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for non-empty mutable vectors, observed by freezing them +-- into lists. +-- +module Test.Data.Vector.NonEmpty.Mutable +( tests +) where + + +import Control.Exception (SomeException, evaluate, try) +import Control.Monad.ST (ST, runST) + +import Data.Either (isLeft) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.STRef (modifySTRef', newSTRef, readSTRef) +import qualified Data.Vector as V +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as MV +import Data.Vector.NonEmpty.Internal + ( NonEmptyMVector(..) + , NonEmptyVector(..) + , NonEmptyIOVector + , NonEmptySTVector + ) +import qualified Data.Vector.NonEmpty.Mutable as NEMV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Mutable" + [ testGroup "Length information" + [ testProperty "prop_length" prop_length + ] + , testGroup "Extracting subvectors" + [ testProperty "prop_slice" prop_slice + , testProperty "prop_slice_shares" prop_slice_shares + , testProperty "prop_init" prop_init + , testProperty "prop_tail" prop_tail + , testProperty "prop_take" prop_take + , testProperty "prop_drop" prop_drop + , testProperty "prop_splitAt" prop_splitAt + , testProperty "prop_unsafeSlice" prop_unsafeSlice + , testProperty "prop_unsafeTake" prop_unsafeTake + , testProperty "prop_unsafeDrop" prop_unsafeDrop + ] + , testGroup "Overlapping" + [ testProperty "prop_overlaps_self" prop_overlaps_self + , testProperty "prop_overlaps_distinct" prop_overlaps_distinct + , testProperty "prop_overlaps_slices" prop_overlaps_slices + ] + , testGroup "Conversions" + [ testProperty "prop_fromMVector" prop_fromMVector + , testProperty "prop_toMVector" prop_toMVector + , testProperty "prop_unsafeFromMVector" prop_unsafeFromMVector + ] + , testGroup "Initialisation" + [ testProperty "prop_new" prop_new + , testProperty "prop_new1" prop_new1 + , testProperty "prop_unsafeNew" prop_unsafeNew + , testProperty "prop_replicate" prop_replicate + , testProperty "prop_replicate1" prop_replicate1 + , testProperty "prop_replicateM" prop_replicateM + , testProperty "prop_replicate1M" prop_replicate1M + , testProperty "prop_clone" prop_clone + ] + , testGroup "Growing" + [ testProperty "prop_grow" prop_grow + , testProperty "prop_grow_negative" prop_grow_negative + , testProperty "prop_unsafeGrow" prop_unsafeGrow + ] + , testGroup "Restricting memory usage" + [ testProperty "prop_clear" prop_clear + ] + , testGroup "Accessing individual elements" + [ testProperty "prop_read" prop_read + , testProperty "prop_read_out_of_bounds" prop_read_out_of_bounds + , testProperty "prop_write" prop_write + , testProperty "prop_write_out_of_bounds" prop_write_out_of_bounds + , testProperty "prop_modify" prop_modify + , testProperty "prop_swap" prop_swap + , testProperty "prop_unsafeRead" prop_unsafeRead + , testProperty "prop_unsafeWrite" prop_unsafeWrite + , testProperty "prop_unsafeModify" prop_unsafeModify + , testProperty "prop_unsafeSwap" prop_unsafeSwap + ] + , testGroup "Modifying vectors" + [ testProperty "prop_nextPermutation" prop_nextPermutation + , testProperty "prop_nextPermutation_last" prop_nextPermutation_last + ] + , testGroup "Filling and copying" + [ testProperty "prop_set" prop_set + , testProperty "prop_copy" prop_copy + , testProperty "prop_copy_length_mismatch" prop_copy_length_mismatch + , testProperty "prop_unsafeCopy" prop_unsafeCopy + , testProperty "prop_move" prop_move + , testProperty "prop_unsafeMove" prop_unsafeMove + ] + ] + +type V = NonEmptyVector Int + +-- ---------------------------------------------------------------------- -- +-- Running mutable vectors + +thaw :: NonEmptyVector a -> ST s (NonEmptySTVector s a) +thaw = fmap NonEmptyMVector . V.thaw . _neVec + +thawIO :: NonEmptyVector a -> IO (NonEmptyIOVector a) +thawIO = fmap NonEmptyMVector . V.thaw . _neVec + +-- | Run a computation against a fresh mutable copy of the vector. +-- +withThawed :: NonEmptyVector a -> (forall s. NonEmptySTVector s a -> ST s b) -> b +withThawed v k = runST (thaw v >>= k) + +freezeList :: MVector s a -> ST s [a] +freezeList = fmap V.toList . V.freeze + +freeze :: NonEmptySTVector s a -> ST s [a] +freeze = freezeList . _nemVec + +-- | A mutable operation's effect on the vector's contents. +-- +mutated :: V -> (forall s. NonEmptySTVector s Int -> ST s ()) -> [Int] +mutated v k = withThawed v (\mv -> k mv >> freeze mv) + +-- ---------------------------------------------------------------------- -- +-- Length information + +prop_length :: V -> Property +prop_length v = withThawed v (pure . NEMV.length) === List.length (elems v) + +-- ---------------------------------------------------------------------- -- +-- Extracting subvectors + +prop_slice :: V -> Property +prop_slice v = forAll (genSlice v) $ \(i, m) -> + withThawed v (freezeList . NEMV.slice i m) + === List.take m (List.drop i (elems v)) + +-- Subvectors are views: writes through them reach the parent vector. +prop_slice_shares :: V -> Int -> Property +prop_slice_shares v a = forAll (genIndex v) $ \i -> + mutated v (\mv -> MV.write (NEMV.drop i mv) 0 a) + === adjustAt i (const a) (elems v) + +prop_init :: V -> Property +prop_init v = + withThawed v (freezeList . NEMV.init) + === List.take (List.length (elems v) - 1) (elems v) + +prop_tail :: V -> Property +prop_tail v = withThawed v (freezeList . NEMV.tail) === List.drop 1 (elems v) + +prop_take :: Int -> V -> Property +prop_take n v = + withThawed v (freezeList . NEMV.take n) === List.take n (elems v) + +prop_drop :: Int -> V -> Property +prop_drop n v = + withThawed v (freezeList . NEMV.drop n) === List.drop n (elems v) + +prop_splitAt :: Int -> V -> Property +prop_splitAt n v = + withThawed v (\mv -> let (as, bs) = NEMV.splitAt n mv + in (,) <$> freezeList as <*> freezeList bs) + === List.splitAt n (elems v) + +prop_unsafeSlice :: V -> Property +prop_unsafeSlice v = forAll (genSlice v) $ \(i, m) -> + withThawed v (freezeList . NEMV.unsafeSlice i m) + === List.take m (List.drop i (elems v)) + +prop_unsafeTake :: V -> Property +prop_unsafeTake v = forAll (choose (0, List.length (elems v))) $ \n -> + withThawed v (freezeList . NEMV.unsafeTake n) === List.take n (elems v) + +prop_unsafeDrop :: V -> Property +prop_unsafeDrop v = forAll (choose (0, List.length (elems v))) $ \n -> + withThawed v (freezeList . NEMV.unsafeDrop n) === List.drop n (elems v) + +-- ---------------------------------------------------------------------- -- +-- Overlapping + +prop_overlaps_self :: V -> Property +prop_overlaps_self v = withThawed v (\mv -> pure (NEMV.overlaps mv mv)) === True + +prop_overlaps_distinct :: V -> V -> Property +prop_overlaps_distinct v w = runST (NEMV.overlaps <$> thaw v <*> thaw w) === False + +-- Adjacent slices are disjoint; extending one by an element overlaps them. +prop_overlaps_slices :: V -> Property +prop_overlaps_slices v = n >= 2 ==> forAll (choose (1, n - 1)) $ \k -> + withThawed v (\(NonEmptyMVector mv) -> + let front m = NonEmptyMVector (MV.take m mv) + back = NonEmptyMVector (MV.drop k mv) + in pure (NEMV.overlaps (front k) back, NEMV.overlaps (front (k + 1)) back)) + === (False, True) + where + n = List.length (elems v) + +-- ---------------------------------------------------------------------- -- +-- Conversions + +prop_fromMVector :: [Int] -> Property +prop_fromMVector as = + runST (V.thaw (V.fromList as) >>= traverse freeze . NEMV.fromMVector) + === whenNonEmpty as + +prop_toMVector :: V -> Property +prop_toMVector v = withThawed v (freezeList . NEMV.toMVector) === elems v + +prop_unsafeFromMVector :: V -> Property +prop_unsafeFromMVector v = + runST (V.thaw (_neVec v) >>= freeze . NEMV.unsafeFromMVector) === elems v + +-- ---------------------------------------------------------------------- -- +-- Initialisation + +prop_new :: NonNegative Int -> Property +prop_new (NonNegative n) = + runST (fmap NEMV.length <$> NEMV.new n) + === if n > 0 then Just n else Nothing + +prop_new1 :: Int -> Property +prop_new1 n = runST (NEMV.length <$> NEMV.new1 n) === max n 1 + +prop_unsafeNew :: NonNegative Int -> Property +prop_unsafeNew (NonNegative n) = + runST (fmap NEMV.length <$> NEMV.unsafeNew n) + === if n > 0 then Just n else Nothing + +prop_replicate :: Int -> Int -> Property +prop_replicate n a = + runST (NEMV.replicate n a >>= traverse freeze) + === whenNonEmpty (List.replicate n a) + +prop_replicate1 :: Int -> Int -> Property +prop_replicate1 n a = + runST (NEMV.replicate1 n a >>= freeze) === List.replicate (max n 1) a + +-- The action runs once per element, in order. +prop_replicateM :: Int -> Property +prop_replicateM n = + runST (counter >>= NEMV.replicateM n >>= traverse freeze) + === whenNonEmpty [1 .. n] + +prop_replicate1M :: Int -> Property +prop_replicate1M n = + runST (counter >>= NEMV.replicate1M n >>= traverse freeze) + === Just [1 .. max n 1] + +-- | An action yielding 1, 2, 3, ... on successive runs. +-- +counter :: ST s (ST s Int) +counter = do + ref <- newSTRef 0 + pure (modifySTRef' ref (+ 1) >> readSTRef ref) + +-- A clone has the same contents but no longer aliases the original. +prop_clone :: V -> Int -> Property +prop_clone v a = + withThawed v (\mv -> do + c <- NEMV.clone mv + MV.set (_nemVec c) a + (,) <$> freeze mv <*> freeze c) + === (elems v, List.map (const a) (elems v)) + +-- ---------------------------------------------------------------------- -- +-- Growing + +prop_grow :: V -> NonNegative Int -> Property +prop_grow v (NonNegative n) = + withThawed v (\mv -> do + g <- NEMV.grow mv n + as <- freezeList (MV.take (NEMV.length mv) (_nemVec g)) + pure (NEMV.length g, as)) + === (List.length (elems v) + n, elems v) + +prop_grow_negative :: V -> Positive Int -> Property +prop_grow_negative v (Positive n) = + throwsIO (thawIO v >>= \mv -> NEMV.grow mv (negate n)) + +prop_unsafeGrow :: V -> NonNegative Int -> Property +prop_unsafeGrow v (NonNegative n) = + withThawed v (\mv -> do + g <- NEMV.unsafeGrow mv n + as <- freezeList (MV.take (NEMV.length mv) (_nemVec g)) + pure (NEMV.length g, as)) + === (List.length (elems v) + n, elems v) + +-- ---------------------------------------------------------------------- -- +-- Restricting memory usage + +-- Clearing keeps the length but releases every element. +prop_clear :: V -> Property +prop_clear v = forAll (genIndex v) $ \i -> ioProperty $ do + mv <- thawIO v + NEMV.clear mv + a <- NEMV.read mv i + r <- try (evaluate a) + pure $ NEMV.length mv === List.length (elems v) + .&&. counterexample "element survived clear" + (isLeft (r :: Either SomeException Int)) + +-- ---------------------------------------------------------------------- -- +-- Accessing individual elements + +prop_read :: V -> Property +prop_read v = forAll (genIndex v) $ \i -> + Just (withThawed v (`NEMV.read` i)) === lookupList i (elems v) + +prop_read_out_of_bounds :: V -> Property +prop_read_out_of_bounds v = forAll (genOutOfBounds v) $ \i -> + throwsIO (thawIO v >>= (`NEMV.read` i)) + +prop_write :: V -> Int -> Property +prop_write v a = forAll (genIndex v) $ \i -> + mutated v (\mv -> NEMV.write mv i a) === adjustAt i (const a) (elems v) + +prop_write_out_of_bounds :: V -> Int -> Property +prop_write_out_of_bounds v a = forAll (genOutOfBounds v) $ \i -> + throwsIO (thawIO v >>= \mv -> NEMV.write mv i a) + +prop_modify :: Fun Int Int -> V -> Property +prop_modify (Fn f) v = forAll (genIndex v) $ \i -> + mutated v (\mv -> NEMV.modify mv f i) === adjustAt i f (elems v) + +prop_swap :: V -> Property +prop_swap v = forAll ((,) <$> genIndex v <*> genIndex v) $ \(i, j) -> + mutated v (\mv -> NEMV.swap mv i j) === swapAt i j (elems v) + +prop_unsafeRead :: V -> Property +prop_unsafeRead v = forAll (genIndex v) $ \i -> + Just (withThawed v (`NEMV.unsafeRead` i)) === lookupList i (elems v) + +prop_unsafeWrite :: V -> Int -> Property +prop_unsafeWrite v a = forAll (genIndex v) $ \i -> + mutated v (\mv -> NEMV.unsafeWrite mv i a) === adjustAt i (const a) (elems v) + +prop_unsafeModify :: Fun Int Int -> V -> Property +prop_unsafeModify (Fn f) v = forAll (genIndex v) $ \i -> + mutated v (\mv -> NEMV.unsafeModify mv f i) === adjustAt i f (elems v) + +prop_unsafeSwap :: V -> Property +prop_unsafeSwap v = forAll ((,) <$> genIndex v <*> genIndex v) $ \(i, j) -> + mutated v (\mv -> NEMV.unsafeSwap mv i j) === swapAt i j (elems v) + +-- ---------------------------------------------------------------------- -- +-- Modifying vectors + +-- Starting from sorted order, successive permutations enumerate every +-- distinct permutation in lexicographic order. +prop_nextPermutation :: Property +prop_nextPermutation = + forAll (choose (1, 5)) $ \n -> + forAll (vectorOf n (choose (0, 3))) $ \as -> + let sorted = List.sort (as :: [Int]) + in withThawed (vec sorted) enumerate + === List.map NonEmpty.head + (NonEmpty.group (List.sort (List.permutations sorted))) + where + enumerate :: NonEmptySTVector s Int -> ST s [[Int]] + enumerate mv = do + as <- freeze mv + more <- NEMV.nextPermutation mv + if more then (as :) <$> enumerate mv else pure [as] + +-- The last permutation has no successor and is left unchanged. +prop_nextPermutation_last :: V -> Property +prop_nextPermutation_last v = + withThawed (vec descending) (\mv -> (,) <$> NEMV.nextPermutation mv <*> freeze mv) + === (False, descending) + where + descending = List.sortBy (flip compare) (elems v) + +-- ---------------------------------------------------------------------- -- +-- Filling and copying + +prop_set :: V -> Int -> Property +prop_set v a = + mutated v (`NEMV.set` a) === List.map (const a) (elems v) + +-- | Copy @v@ over a vector of the same length, returning the target and +-- source contents afterwards. +-- +copied + :: (forall s. NonEmptySTVector s Int -> NonEmptySTVector s Int -> ST s ()) + -> V + -> [Int] + -> ([Int], [Int]) +copied cp v bs = runST $ do + dst <- thaw (vec bs) + src <- thaw v + cp dst src + (,) <$> freeze dst <*> freeze src + +prop_copy :: V -> Property +prop_copy v = forAll (vectorOf (List.length (elems v)) arbitrary) $ \bs -> + copied NEMV.copy v bs === (elems v, elems v) + +prop_copy_length_mismatch :: V -> Property +prop_copy_length_mismatch v = throwsIO $ do + dst <- thawIO (vec (0 : elems v)) + src <- thawIO v + NEMV.copy dst src + +prop_unsafeCopy :: V -> Property +prop_unsafeCopy v = forAll (vectorOf (List.length (elems v)) arbitrary) $ \bs -> + copied NEMV.unsafeCopy v bs === (elems v, elems v) + +-- | Move between the overlapping slices @[0, n - 1)@ and @[1, n)@ of one +-- vector, in both directions. +-- +moved + :: (forall s. NonEmptySTVector s Int -> NonEmptySTVector s Int -> ST s ()) + -> V + -> ([Int], [Int]) +moved mv v = (shift True, shift False) + where + n = List.length (elems v) + + shift left = withThawed v $ \(NonEmptyMVector raw) -> do + let lo = NonEmptyMVector (MV.slice 0 (n - 1) raw) + hi = NonEmptyMVector (MV.slice 1 (n - 1) raw) + if left then mv lo hi else mv hi lo + freezeList raw + +prop_move :: V -> Property +prop_move v = List.length as >= 2 ==> + moved NEMV.move v + === (List.drop 1 as ++ List.drop (n - 1) as, List.take 1 as ++ List.take (n - 1) as) + where + as = elems v + n = List.length as + +prop_unsafeMove :: V -> Property +prop_unsafeMove v = List.length as >= 2 ==> + moved NEMV.unsafeMove v + === (List.drop 1 as ++ List.drop (n - 1) as, List.take 1 as ++ List.take (n - 1) as) + where + as = elems v + n = List.length as diff --git a/test/Test/Data/Vector/NonEmpty/Predicates.hs b/test/Test/Data/Vector/NonEmpty/Predicates.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Predicates.hs @@ -0,0 +1,192 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Predicates +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for filtering, partitioning, and searching. +-- +-- Elements are reduced modulo a small number where duplicates or hits +-- need to be likely. +-- +module Test.Data.Vector.NonEmpty.Predicates +( tests +) where + + +import Data.Either (partitionEithers) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe +import qualified Data.Vector as V +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Predicates" + [ testGroup "Filtering" + [ testProperty "prop_uniq" prop_uniq + , testProperty "prop_mapMaybe" prop_mapMaybe + , testProperty "prop_imapMaybe" prop_imapMaybe + , testProperty "prop_filter" prop_filter + , testProperty "prop_ifilter" prop_ifilter + , testProperty "prop_filterM" prop_filterM + , testProperty "prop_ifilterM" prop_ifilterM + , testProperty "prop_takeWhile" prop_takeWhile + , testProperty "prop_dropWhile" prop_dropWhile + ] + , testGroup "Partitioning" + [ testProperty "prop_partition" prop_partition + , testProperty "prop_partitionWith" prop_partitionWith + , testProperty "prop_unstablePartition" prop_unstablePartition + , testProperty "prop_span" prop_span + , testProperty "prop_break" prop_break + ] + , testGroup "Searching" + [ testProperty "prop_elem" prop_elem + , testProperty "prop_notElem" prop_notElem + , testProperty "prop_find" prop_find + , testProperty "prop_findIndex" prop_findIndex + , testProperty "prop_findIndices" prop_findIndices + , testProperty "prop_elemIndex" prop_elemIndex + , testProperty "prop_elemIndices" prop_elemIndices + ] + ] + +type V = NonEmptyVector Int + +-- | Reduce elements to a small range so that duplicates and matches are +-- common. +-- +small :: V -> V +small = vec . List.map (`mod` 4) . elems + +-- ---------------------------------------------------------------------- -- +-- Filtering + +prop_uniq :: V -> Property +prop_uniq v = + elems (NEV.uniq w) === List.map NonEmpty.head (NonEmpty.group (elems w)) + where + w = small v + +prop_mapMaybe :: Fun Int (Maybe Int) -> V -> Property +prop_mapMaybe (Fn f) v = + V.toList (NEV.mapMaybe f v) === Maybe.mapMaybe f (elems v) + +prop_imapMaybe :: Fun (Int, Int) (Maybe Int) -> V -> Property +prop_imapMaybe (Fn2 f) v = + V.toList (NEV.imapMaybe f v) + === Maybe.catMaybes (List.zipWith f [0 ..] (elems v)) + +prop_filter :: Fun Int Bool -> V -> Property +prop_filter (Fn p) v = V.toList (NEV.filter p v) === List.filter p (elems v) + +prop_ifilter :: Fun (Int, Int) Bool -> V -> Property +prop_ifilter (Fn2 p) v = + V.toList (NEV.ifilter p v) + === [ a | (i, a) <- List.zip [0 ..] (elems v), p i a ] + +prop_filterM :: Fun Int Bool -> V -> Property +prop_filterM (Fn p) v = + fmap V.toList (NEV.filterM (\a -> logged a (p a)) v) + === (elems v, List.filter p (elems v)) + +prop_ifilterM :: Fun (Int, Int) Bool -> V -> Property +prop_ifilterM (Fn2 p) v = + fmap V.toList (NEV.ifilterM (\i a -> logged i (p i a)) v) + === ( List.map fst ias + , [ a | (i, a) <- ias, p i a ] + ) + where + ias = List.zip [0 ..] (elems v) + +prop_takeWhile :: Fun Int Bool -> V -> Property +prop_takeWhile (Fn p) v = + V.toList (NEV.takeWhile p v) === List.takeWhile p (elems v) + +prop_dropWhile :: Fun Int Bool -> V -> Property +prop_dropWhile (Fn p) v = + V.toList (NEV.dropWhile p v) === List.dropWhile p (elems v) + +-- ---------------------------------------------------------------------- -- +-- Partitioning + +prop_partition :: Fun Int Bool -> V -> Property +prop_partition (Fn p) v = + (V.toList as, V.toList bs) === List.partition p (elems v) + where + (as, bs) = NEV.partition p v + +prop_partitionWith :: Fun Int (Either Int Int) -> V -> Property +prop_partitionWith (Fn f) v = + (V.toList as, V.toList bs) === partitionEithers (List.map f (elems v)) + where + (as, bs) = NEV.partitionWith f v + +-- Only the contents of each side are specified, not their order. +prop_unstablePartition :: Fun Int Bool -> V -> Property +prop_unstablePartition (Fn p) v = + (List.sort (V.toList as), List.sort (V.toList bs)) + === (List.sort ts, List.sort fs) + where + (as, bs) = NEV.unstablePartition p v + (ts, fs) = List.partition p (elems v) + +prop_span :: Fun Int Bool -> V -> Property +prop_span (Fn p) v = + (V.toList as, V.toList bs) === List.span p (elems v) + where + (as, bs) = NEV.span p v + +prop_break :: Fun Int Bool -> V -> Property +prop_break (Fn p) v = + (V.toList as, V.toList bs) === List.break p (elems v) + where + (as, bs) = NEV.break p v + +-- ---------------------------------------------------------------------- -- +-- Searching + +prop_elem :: Int -> V -> Property +prop_elem a v = NEV.elem (a `mod` 4) w === List.elem (a `mod` 4) (elems w) + where + w = small v + +prop_notElem :: Int -> V -> Property +prop_notElem a v = + NEV.notElem (a `mod` 4) w === List.notElem (a `mod` 4) (elems w) + where + w = small v + +prop_find :: Fun Int Bool -> V -> Property +prop_find (Fn p) v = NEV.find p v === List.find p (elems v) + +prop_findIndex :: Fun Int Bool -> V -> Property +prop_findIndex (Fn p) v = NEV.findIndex p v === List.findIndex p (elems v) + +prop_findIndices :: Fun Int Bool -> V -> Property +prop_findIndices (Fn p) v = + V.toList (NEV.findIndices p v) === List.findIndices p (elems v) + +prop_elemIndex :: Int -> V -> Property +prop_elemIndex a v = + NEV.elemIndex (a `mod` 4) w === List.elemIndex (a `mod` 4) (elems w) + where + w = small v + +prop_elemIndices :: Int -> V -> Property +prop_elemIndices a v = + V.toList (NEV.elemIndices (a `mod` 4) w) + === List.elemIndices (a `mod` 4) (elems w) + where + w = small v diff --git a/test/Test/Data/Vector/NonEmpty/Scans.hs b/test/Test/Data/Vector/NonEmpty/Scans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Scans.hs @@ -0,0 +1,215 @@ +-- | +-- Module : Test.Data.Vector.NonEmpty.Scans +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Properties for prefix sums (scans) and transformations. +-- +-- Scan functions are arbitrary, hence neither associative nor commutative, +-- so the models pin down scan direction and argument order. +-- +module Test.Data.Vector.NonEmpty.Scans +( tests +) where + + +import qualified Data.List as List +import qualified Data.Vector as V +import Data.Vector.NonEmpty (NonEmptyVector) +import qualified Data.Vector.NonEmpty as NEV + +import Test.Data.Vector.NonEmpty.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Scans" + [ testGroup "Prefix sums" + [ testProperty "prop_prescanl" prop_prescanl + , testProperty "prop_prescanl'" prop_prescanl' + , testProperty "prop_postscanl" prop_postscanl + , testProperty "prop_postscanl'" prop_postscanl' + , testProperty "prop_scanl" prop_scanl + , testProperty "prop_scanl'" prop_scanl' + , testProperty "prop_scanl1" prop_scanl1 + , testProperty "prop_scanl1'" prop_scanl1' + , testProperty "prop_iscanl" prop_iscanl + , testProperty "prop_iscanl'" prop_iscanl' + , testProperty "prop_prescanr" prop_prescanr + , testProperty "prop_prescanr'" prop_prescanr' + , testProperty "prop_postscanr" prop_postscanr + , testProperty "prop_postscanr'" prop_postscanr' + , testProperty "prop_scanr" prop_scanr + , testProperty "prop_scanr'" prop_scanr' + , testProperty "prop_scanr1" prop_scanr1 + , testProperty "prop_scanr1'" prop_scanr1' + , testProperty "prop_iscanr" prop_iscanr + , testProperty "prop_iscanr'" prop_iscanr' + ] + , testGroup "Intersperse tests" + [ testProperty "prop_intersperse" prop_intersperse + , testProperty "prop_intersperse_length" prop_intersperse_length + , testProperty "prop_intersperse_first_last" prop_intersperse_first_last + , testProperty "prop_intersperse_separator" prop_intersperse_separator + , testProperty "prop_intersperse_reconstruction" prop_intersperse_reconstruction + , testProperty "prop_intersperse_singleton" prop_intersperse_singleton + , testProperty "prop_explicit_examples" prop_explicit_examples + ] + ] + +type V = NonEmptyVector Int + +-- ---------------------------------------------------------------------- -- +-- Models + +-- | Left scan over @(index, element)@ pairs. +-- +iscanlList :: (Int -> a -> b -> a) -> a -> [b] -> [a] +iscanlList f z = List.scanl (\acc (i, b) -> f i acc b) z . List.zip [0 ..] + +-- | Right scan over @(index, element)@ pairs. +-- +iscanrList :: (Int -> a -> b -> b) -> b -> [a] -> [b] +iscanrList f z = List.scanr (\(i, a) acc -> f i a acc) z . List.zip [0 ..] + +-- ---------------------------------------------------------------------- -- +-- Left scans + +prop_prescanl :: Fun (Int, Int) Int -> Int -> V -> Property +prop_prescanl (Fn2 f) z v = + elems (NEV.prescanl f z v) + === List.take (NEV.length v) (List.scanl f z (elems v)) + +prop_prescanl' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_prescanl' (Fn2 f) z v = + elems (NEV.prescanl' f z v) + === List.take (NEV.length v) (List.scanl f z (elems v)) + +prop_postscanl :: Fun (Int, Int) Int -> Int -> V -> Property +prop_postscanl (Fn2 f) z v = + elems (NEV.postscanl f z v) === List.drop 1 (List.scanl f z (elems v)) + +prop_postscanl' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_postscanl' (Fn2 f) z v = + elems (NEV.postscanl' f z v) === List.drop 1 (List.scanl f z (elems v)) + +prop_scanl :: Fun (Int, Int) Int -> Int -> V -> Property +prop_scanl (Fn2 f) z v = elems (NEV.scanl f z v) === List.scanl f z (elems v) + +prop_scanl' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_scanl' (Fn2 f) z v = elems (NEV.scanl' f z v) === List.scanl f z (elems v) + +prop_scanl1 :: Fun (Int, Int) Int -> V -> Property +prop_scanl1 (Fn2 f) v = elems (NEV.scanl1 f v) === List.scanl1 f (elems v) + +prop_scanl1' :: Fun (Int, Int) Int -> V -> Property +prop_scanl1' (Fn2 f) v = elems (NEV.scanl1' f v) === List.scanl1 f (elems v) + +prop_iscanl :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_iscanl (Fn3 f) z v = + elems (NEV.iscanl f z v) === iscanlList f z (elems v) + +prop_iscanl' :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_iscanl' (Fn3 f) z v = + elems (NEV.iscanl' f z v) === iscanlList f z (elems v) + +-- ---------------------------------------------------------------------- -- +-- Right scans + +prop_prescanr :: Fun (Int, Int) Int -> Int -> V -> Property +prop_prescanr (Fn2 f) z v = + elems (NEV.prescanr f z v) === List.drop 1 (List.scanr f z (elems v)) + +prop_prescanr' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_prescanr' (Fn2 f) z v = + elems (NEV.prescanr' f z v) === List.drop 1 (List.scanr f z (elems v)) + +prop_postscanr :: Fun (Int, Int) Int -> Int -> V -> Property +prop_postscanr (Fn2 f) z v = + elems (NEV.postscanr f z v) + === List.take (NEV.length v) (List.scanr f z (elems v)) + +prop_postscanr' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_postscanr' (Fn2 f) z v = + elems (NEV.postscanr' f z v) + === List.take (NEV.length v) (List.scanr f z (elems v)) + +prop_scanr :: Fun (Int, Int) Int -> Int -> V -> Property +prop_scanr (Fn2 f) z v = elems (NEV.scanr f z v) === List.scanr f z (elems v) + +prop_scanr' :: Fun (Int, Int) Int -> Int -> V -> Property +prop_scanr' (Fn2 f) z v = elems (NEV.scanr' f z v) === List.scanr f z (elems v) + +prop_scanr1 :: Fun (Int, Int) Int -> V -> Property +prop_scanr1 (Fn2 f) v = elems (NEV.scanr1 f v) === List.scanr1 f (elems v) + +prop_scanr1' :: Fun (Int, Int) Int -> V -> Property +prop_scanr1' (Fn2 f) v = elems (NEV.scanr1' f v) === List.scanr1 f (elems v) + +prop_iscanr :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_iscanr (Fn3 f) z v = + elems (NEV.iscanr f z v) === iscanrList f z (elems v) + +prop_iscanr' :: Fun (Int, Int, Int) Int -> Int -> V -> Property +prop_iscanr' (Fn3 f) z v = + elems (NEV.iscanr' f z v) === iscanrList f z (elems v) + +-- ---------------------------------------------------------------------- -- +-- Intersperse properties + +prop_intersperse :: Int -> V -> Property +prop_intersperse sep v = + elems (NEV.intersperse sep v) === List.intersperse sep (elems v) + +-- For vectors with length > 1, interspersing should result in length 2*n - 1 +prop_intersperse_length :: Int -> V -> Bool +prop_intersperse_length sep v = + let result = NEV.intersperse sep v + originalLen = NEV.length v + in if originalLen > 1 + then NEV.length result == 2 * originalLen - 1 + else NEV.length result == originalLen + +-- The first and last elements of the result should match the original vector +prop_intersperse_first_last :: Int -> V -> Bool +prop_intersperse_first_last sep v = + let result = NEV.intersperse sep v + in NEV.head result == NEV.head v && NEV.last result == NEV.last v + +-- Every odd-indexed element should be the separator (for vectors with length > 1) +prop_intersperse_separator :: Int -> V -> Bool +prop_intersperse_separator sep v = + let result = NEV.intersperse sep v + in NEV.length v <= 1 || + all (\i -> result NEV.! (2*i+1) == sep) [0 .. NEV.length v - 2] + +-- If we remove the separator, we should get back the original vector +prop_intersperse_reconstruction :: Int -> V -> Bool +prop_intersperse_reconstruction sep v = + let result = NEV.intersperse sep v + resultVector = NEV.toVector result + reconstructed = V.ifilter (\i _ -> i `mod` 2 == 0) resultVector + in V.toList reconstructed == NEV.toList v + +-- For singleton vectors, interspersing should not change the vector +prop_intersperse_singleton :: Int -> Int -> Bool +prop_intersperse_singleton x sep = + let singleton = NEV.singleton x + result = NEV.intersperse sep singleton + in result == singleton + +-- Explicit test cases for edge cases and examples combined into one property +prop_explicit_examples :: Property +prop_explicit_examples = + let normalCase = NEV.intersperse (0 :: Int) (NEV.unsafeFromList [1,2,3 :: Int]) + === NEV.unsafeFromList [1,0,2,0,3 :: Int] + + singletonCase = NEV.intersperse (0 :: Int) (NEV.singleton (5 :: Int)) + === NEV.singleton (5 :: Int) + in normalCase .&&. singletonCase diff --git a/test/Test/Data/Vector/NonEmpty/Util.hs b/test/Test/Data/Vector/NonEmpty/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Vector/NonEmpty/Util.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Test.Data.Vector.NonEmpty.Util +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : experimental +-- Portability : non-portable +-- +-- Generators, list models, and property helpers shared by the +-- non-empty vector test suite. +-- +-- Vectors are built and observed through the representation exposed by +-- "Data.Vector.NonEmpty.Internal", so that the models never depend on +-- the API under test. +-- +module Test.Data.Vector.NonEmpty.Util +( -- * Building and observing vectors + vec +, elems +, elems1 +, whenNonEmpty + -- * Generators +, genIndex +, genIndices +, genOutOfBounds +, genSlice +, genUpdates + -- * Effects +, logged +, unfoldStep + -- * List models +, adjustAt +, lookupList +, swapAt +, unfoldrMList +, unfoldrNMList + -- * Exceptions +, throws +, throwsIO +) where + + +import Control.DeepSeq (NFData, force) +import Control.Exception (SomeException, evaluate, try) + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Vector as V +import Data.Vector.NonEmpty.Internal (NonEmptyVector(..)) + +import Test.QuickCheck + + +instance Arbitrary a => Arbitrary (NonEmptyVector a) where + arbitrary = vec . getNonEmpty <$> arbitrary + shrink = fmap (vec . getNonEmpty) . shrink . NonEmpty . elems + +-- ---------------------------------------------------------------------- -- +-- Building and observing vectors + +-- | Build a non-empty vector from its representation. The caller +-- guarantees that the list is non-empty. +-- +vec :: [a] -> NonEmptyVector a +vec = NonEmptyVector . V.fromList + +-- | The elements of a non-empty vector, read from its representation. +-- +elems :: NonEmptyVector a -> [a] +elems = V.toList . _neVec + +-- | The elements of a non-empty vector as a non-empty list, read from its +-- representation. +-- +elems1 :: NonEmptyVector a -> NonEmpty a +elems1 (NonEmptyVector v) = V.unsafeHead v :| V.toList (V.unsafeTail v) + +-- | Model of the 'Maybe'-valued constructors: 'Nothing' exactly when the +-- result would be empty. +-- +whenNonEmpty :: [a] -> Maybe [a] +whenNonEmpty [] = Nothing +whenNonEmpty as = Just as + +-- ---------------------------------------------------------------------- -- +-- Generators + +-- | A valid index into the vector. +-- +genIndex :: NonEmptyVector a -> Gen Int +genIndex (NonEmptyVector v) = choose (0, V.length v - 1) + +-- | A non-empty vector of valid indices into the vector. +-- +genIndices :: NonEmptyVector a -> Gen (NonEmptyVector Int) +genIndices v = vec <$> listOf1 (genIndex v) + +-- | An index outside the bounds of the vector, on either side. +-- +genOutOfBounds :: NonEmptyVector a -> Gen Int +genOutOfBounds (NonEmptyVector v) = oneof + [ choose (-10, -1) + , choose (n, n + 10) + ] + where + n = V.length v + +-- | A valid @(offset, length)@ slice of the vector, possibly empty. +-- +genSlice :: NonEmptyVector a -> Gen (Int, Int) +genSlice (NonEmptyVector v) = do + i <- choose (0, n) + m <- choose (0, n - i) + pure (i, m) + where + n = V.length v + +-- | A list of updates at valid indices of the vector. +-- +genUpdates :: Arbitrary b => NonEmptyVector a -> Gen [(Int, b)] +genUpdates v = listOf ((,) <$> genIndex v <*> arbitrary) + +-- ---------------------------------------------------------------------- -- +-- Effects + +-- | A writer-style action that records @w@ and yields @a@. Running monadic +-- operations in @([w], -)@ exposes the order and number of effects. +-- +logged :: w -> a -> ([w], a) +logged w a = ([w], a) + +-- | A terminating unfold step: counts the seed down to zero, emitting +-- @f seed@ at each step. +-- +unfoldStep :: (Int -> a) -> Int -> Maybe (a, Int) +unfoldStep f b + | b <= 0 = Nothing + | otherwise = Just (f b, b - 1) + +-- ---------------------------------------------------------------------- -- +-- List models + +-- | Apply a function at an index, leaving the list unchanged when the index +-- is out of bounds. +-- +adjustAt :: Int -> (a -> a) -> [a] -> [a] +adjustAt i f as = [ if j == i then f a else a | (j, a) <- zip [0 ..] as ] + +-- | Total list indexing. +-- +lookupList :: Int -> [a] -> Maybe a +lookupList i as + | i < 0 = Nothing + | otherwise = listToMaybe (drop i as) + +-- | Exchange the elements at two indices. +-- +swapAt :: Int -> Int -> [a] -> [a] +swapAt i j as = [ pick k a | (k, a) <- zip [0 ..] as ] + where + pick k a + | k == i = fromMaybe a (lookupList j as) + | k == j = fromMaybe a (lookupList i as) + | otherwise = a + +-- | Monadic 'Data.List.unfoldr'. +-- +unfoldrMList :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrMList f = go + where + go b = f b >>= maybe (pure []) (\(a, b') -> (a :) <$> go b') + +-- | Monadic 'Data.List.unfoldr' producing at most @n@ elements. The step +-- function is not run once @n@ elements have been produced. +-- +unfoldrNMList :: Monad m => Int -> (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrNMList n0 f = go n0 + where + go n b + | n <= 0 = pure [] + | otherwise = f b >>= maybe (pure []) (\(a, b') -> (a :) <$> go (n - 1) b') + +-- ---------------------------------------------------------------------- -- +-- Exceptions + +-- | The value throws when fully evaluated. +-- +throws :: NFData a => a -> Property +throws = throwsIO . evaluate . force + +-- | The action throws when run. +-- +throwsIO :: IO a -> Property +throwsIO act = ioProperty $ do + r <- try act + pure $ case r of + Left (_ :: SomeException) -> property True + Right _ -> counterexample "expected an exception" (property False)