{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
module Properties.Specific where
import Properties.Utils
import Data.Array.Vector.Stream
import Data.Array.Vector.Prim.Hyperstrict
import Data.Array.Vector
import Control.Monad.ST
import Data.Word
import Data.Int
import Data.Complex
import Data.Ratio
import Data.List
import System.IO
import System.Directory
import System.IO.Unsafe
import Debug.Trace
prop_scanResU :: (A -> A -> A) -> A -> UArr A -> Bool
prop_scanResU f x xs = ((\(initU :*: lastU) -> fromU initU ++ [lastU]) $ scanResU f x xs) == scanl f x (fromU xs)
-- Not dealing with the allocation size parameter for now
prop_replicateEachU :: PosUArr -> UArr A -> Bool
prop_replicateEachU (PosUArr r) e = replicateEachU (sumU r) r e == (toU . concat $ zipWith replicate (fromU r) (fromU e))
-- FIXME: doesn't check negative numbers
prop_unitsU n = n >= 0 ==> (fromU . unitsU $ n) == replicate n ()
prop_indexedU :: UArr A -> Bool
prop_indexedU xs = indexedU xs == (toU . zipWith (:*:) [0..] . fromU $ xs)
prop_fstU :: UArr (A :*: B) -> Bool
prop_fstU xs = (fromU . fstU $ xs) == (map fstS . fromU $ xs)
prop_sndU :: UArr (A :*: B) -> Bool
prop_sndU xs = (fromU . sndU $ xs) == (map sndS . fromU $ xs)
prop_repeatU :: Int -> UArr A -> Property
prop_repeatU n xs = n > 0 ==> (fromU $ repeatU n xs) == (concat $ replicate n (fromU xs))
-- FIXME: test for mismatching lengths when it stops crashing the testsuite
prop_packU :: ELUArrs A Bool -> Bool
prop_packU (ELUArrs xs fs) = (fromU $ packU xs fs) == (map fst . filter snd $ zip (fromU xs) (fromU fs))
prop_foldl1MaybeU :: (A -> A -> A) -> UArr A -> Bool
prop_foldl1MaybeU f xs = case foldl1MaybeU f xs of
JustS a -> a == foldl1 f (fromU xs)
_ -> nullU xs
-- FIXME: DRY
prop_fold1MaybeU :: (A -> A -> A) -> UArr A -> Bool
prop_fold1MaybeU f xs = case fold1MaybeU f xs of
JustS a -> a == foldl1 f (fromU xs)
_ -> nullU xs
prop_scanU :: (A -> A -> A) -> A -> UArr A -> Bool
prop_scanU f x xs = (fromU $ scanU f x xs) == (init $ scanl f x (fromU xs))
-- FIXME: test for empty input exception
prop_scan1U :: (A -> A -> A) -> UArr A -> Property
prop_scan1U f xs = (not . nullU $ xs) ==>
(fromU $ scan1U f xs) == (scanl1 f (fromU xs))
prop_mapAccumLU :: (C -> A -> C :*: B) -> C -> UArr A -> Bool
prop_mapAccumLU f x xs = (fromU $ mapAccumLU f x xs) == (snd $ mapAccumL (\a b -> unpairS $ f a b) x (fromU xs))
-- FIXME: we want to test cases in which the generating array doesn't satisfy
-- our conditions, too.
prop_combineU :: (CombineGen A) -> Property
prop_combineU (CombineGen f xs ys) = (lengthU $ filterU id f) == lengthU xs
&& (lengthU $ filterU not f) == lengthU ys ==>
(fromU $ combineU f xs ys) == (reverse . snd $ foldl (\((xs, ys), acc) a -> if a then ((tail xs, ys), (head xs):acc) else ((xs, tail ys), (head ys):acc)) ((fromU xs, fromU ys), []) (fromU f))
------------------------------------------------------------------------
-- *** Enumerated array generators
prop_enumFromToU :: Int -> Int -> Bool
prop_enumFromToU start end = (fromU $ enumFromToU start end) == [start..end]
-- FIXME: not checking when end > start or if either is negative (those should all throw exceptions probably)
prop_enumFromToFracU :: Double -> Double -> Property
prop_enumFromToFracU start end = start <= end ==> (property $ (fromU $ enumFromToFracU start end) == [start..end])
prop_enumFromThenToU :: Int -> Int -> Int -> Property
prop_enumFromThenToU start next end = next /= start ==> (property $ (fromU $ enumFromThenToU start next end) == [start,next..end])
-- FIXME: not checking the length for now
prop_enumFromStepLenU :: Int -> Int -> Int -> Property
prop_enumFromStepLenU start step len = len >= 0 ==> (property $ (fromU $ enumFromStepLenU start step len) == (take len $ [start, (start + step)..]))
-- FIXME: not checking the length for now
prop_enumFromToEachU :: UArr (Int :*: Int) -> Bool
prop_enumFromToEachU reps = (fromU $ enumFromToEachU (sumU . mapU (\(x :*: y) -> max (y - x + 1) 0) $ reps) reps) == (concatMap (\(x :*: y) -> [x..y]) . fromU $ reps)
------------------------------------------------------------------------
-- *** Representation-specific operations
-- These aren't very good tests...
prop_lengthU :: (UA a, Show a) => UArr a -> Bool
prop_lengthU xs = lengthU xs == (length . fromU $ xs)
prop_indexU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property
prop_indexU xs i = i >= 0 && i < lengthU xs ==>
xs `indexU` i == ((!! i) . fromU $ xs)
-- FIXME: check for bounds issues rather than excluding them
prop_sliceU :: (UA a, Eq a, Show a) => BoundedIndex a -> Int -> Property
prop_sliceU (BoundedIndex u start) len = len >= 0 && start >= 0 && lengthU u > 0 ==>
(fromU $ sliceU u start len) == (take len . drop start . fromU $ u)
prop_newMU_copyMU_lengthMU :: (UA a, Show a) => UArr a -> Bool
prop_newMU_copyMU_lengthMU xs = runST (do let len = lengthU xs
mu <- newMU len
copyMU mu 0 xs
return $ lengthMU mu == len)
prop_readMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property
prop_readMU xs i = i >= 0 && i < lengthU xs ==>
runST (do let len = lengthU xs
mu <- newMU len
copyMU mu 0 xs
x <- readMU mu i
return $ x == xs `indexU` i)
prop_writeMU :: (UA a, Eq a, Show a) => UArr a -> Int -> a -> Property
prop_writeMU xs i e = i >= 0 && i < lengthU xs ==>
runST (do let len = lengthU xs
mu <- newMU len
copyMU mu 0 xs
writeMU mu i e
x <- readMU mu i
return $ x == e)
prop_unsafeFreezeMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property
prop_unsafeFreezeMU xs len = len >= 0 && len < lengthU xs ==>
runST (do let l = lengthU xs
mu <- newMU l
copyMU mu 0 xs
unsafeFreezeMU mu len) == takeU len xs
prop_hPutU_hGetU :: (UIO a, Eq a, Show a) => UArr a -> Bool
prop_hPutU_hGetU xs = unsafePerformIO $
do tmp <- getTemporaryDirectory
(path, h) <- openTempFile tmp "uvector_test"
hPutU h xs
hSeek h AbsoluteSeek 0
ys <- hGetU h
hClose h
removeFile path
return $ xs == ys
prop_memcpyMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property
prop_memcpyMU xs len = len >= 0 && len < lengthU xs ==> takeU len frozen == takeU len xs
where frozen = runST (do mu <- newMU $ lengthU xs
mu1 <- newMU $ lengthU xs
copyMU mu 0 xs
memcpyMU mu mu1 len
unsafeFreezeAllMU mu1)
prop_memcpyOffMU :: (UA a, Eq a, Show a) => Ind2LenUArr a -> Property
prop_memcpyOffMU (Ind2LenUArr xs startxs startys len) =
len >= 0 && startxs + len < lengthU xs && startys + len < lengthU xs &&
startxs >= 0 && startys >= 0 ==>
sliceU xs startxs len == sliceU frozen startys len
where frozen = runST (do mu <- newMU $ lengthU xs
mu1 <- newMU $ lengthU xs
copyMU mu 0 xs
memcpyOffMU mu mu1 startxs startys len
unsafeFreezeAllMU mu1)
prop_memmoveOffMU :: (UA a, Eq a, Show a) => Ind2LenUArr a -> Property
prop_memmoveOffMU (Ind2LenUArr xs startxs startys len) =
len >= 0 && startxs + len < lengthU xs && startys + len < lengthU xs &&
startxs >= 0 && startys >= 0 ==>
sliceU xs startxs len == sliceU frozen startys len
where frozen = runST (do mu <- newMU $ lengthU xs
copyMU mu 0 xs
memmoveOffMU mu mu startxs startys len
unsafeFreezeAllMU mu)
------------------------------------------------------------
prop_unsafeFreezeAllMU :: UArr A -> Bool
prop_unsafeFreezeAllMU xs =
runST (do mu <- newMU $ lengthU xs
copyMU mu 0 xs
unsafeFreezeAllMU mu) == xs
prop_newU :: UArr A -> Bool
prop_newU a = newU (lengthU a) (\a' -> copyMU a' 0 a) == a
------------------------------------------------------------------------------
-- these are a bit silly, but I'm aiming for 100% coverage
prop_fstS :: A -> B -> Bool
prop_fstS a b = fstS (a :*: b) == a
prop_sndS :: A -> B -> Bool
prop_sndS a b = sndS (a :*: b) == b
prop_pairS :: A -> B -> Bool
prop_pairS a b = pairS (a, b) == (a :*: b)
prop_unpairS :: A -> B -> Bool
prop_unpairS a b = unpairS (a :*: b) == (a, b)
prop_curryS :: (A :*: B -> C) -> A -> B -> Bool
prop_curryS f a b = curryS f a b == f (a :*: b)
prop_uncurryS :: (A -> B -> C) -> A -> B -> Bool
prop_uncurryS f a b = uncurryS f (a :*: b) == f a b
prop_unsafePairS :: A -> B -> Bool
prop_unsafePairS a b = unsafe_pairS (a, b) == (a :*: b)
prop_unsafeUnpairS :: A -> B -> Bool
prop_unsafeUnpairS a b = unsafe_unpairS (a :*: b) == (a, b)
prop_maybeS :: B -> (A -> B) -> MaybeS A -> Bool
prop_maybeS b f m@(JustS a) = maybeS b f m == f a
prop_maybeS b f m = maybeS b f m == b
prop_fromMaybeS :: A -> MaybeS A -> Bool
prop_fromMaybeS x m@(JustS a) = fromMaybeS x m == a
prop_fromMaybeS x m = fromMaybeS x m == x
prop_functorMaybeS :: (A -> MaybeS A) -> MaybeS A -> Bool
prop_functorMaybeS f m@(JustS a) = fmap f m == JustS (f a)
prop_functorMaybeS f m = fmap f m == NothingS
------------------------------------------------------------------------------
prop_show_read :: UArr A -> Bool
prop_show_read xs = (read . show $ xs) == xs
------------------------------------------------------------------------------
prop_unsafeZipMU :: ELUArrs A A -> Bool
prop_unsafeZipMU (ELUArrs a b) = fstU prod == a && sndU prod == b
where prod = runST (do let aLen = lengthU a
let bLen = lengthU b
aMU <- newMU aLen
bMU <- newMU bLen
copyMU aMU 0 a
copyMU bMU 0 b
unsafeFreezeAllMU $ unsafeZipMU aMU bMU)
prop_unsafeUnzipMU :: UArr (A :*: B) -> Bool
prop_unsafeUnzipMU xs = fstU xs == x && sndU xs == y
where x = runST (do let len = lengthU xs
mu <- newMU len
copyMU mu 0 xs
(\(x :*: y) -> unsafeFreezeAllMU x) $ unsafeUnzipMU mu)
y = runST (do let len = lengthU xs
mu <- newMU len
copyMU mu 0 xs
(\(x :*: y) -> unsafeFreezeAllMU y) $ unsafeUnzipMU mu)