{-# 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)