module Test.Storable where

import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape
import Data.Array.Comfort.Storable (Array, (!))

import Foreign.Storable (Storable)

import qualified Test.QuickCheck as QC
import Test.ChasingBottoms.IsBottom (isBottom)

import Control.Applicative ((<$>))

import Data.Word (Word16)


type ShapeInt = Shape.ZeroBased Int

genArray :: QC.Gen (Array ShapeInt Word16)
genArray = Array.vectorFromList <$> QC.arbitrary


singleton :: (Storable a, Eq a) => a -> Bool
singleton x  =  x == Array.singleton x ! ()

appendTakeDrop ::
   (Storable a, Eq a) =>
   QC.NonNegative Int -> Array ShapeInt a -> Bool
appendTakeDrop (QC.NonNegative n) x =
   x ==
   Array.mapShape (Shape.ZeroBased . Shape.size)
      (Array.append (Array.take n x) (Array.drop n x))

takeLeftRightAppend ::
   (Storable a, Eq a) =>
   Array ShapeInt a -> Array ShapeInt a -> Bool
takeLeftRightAppend x y =
   let xy = Array.append x y
   in x == Array.takeLeft xy  &&  y == Array.takeRight xy


sumList :: (Storable a, Num a, Eq a) => Array ShapeInt a -> Bool
sumList xs  =  Array.sum xs == sum (Array.toList xs)

productList :: (Storable a, Num a, Eq a) => Array ShapeInt a -> Bool
productList xs  =  Array.product xs == product (Array.toList xs)


withNonEmpty ::
   (Array ShapeInt a -> b) ->
   (b -> Array ShapeInt a -> Bool) ->
   Array ShapeInt a -> Bool
withNonEmpty f law xs =
   let x = f xs
   in if Array.shape xs == Shape.ZeroBased 0
         then isBottom x
         else law x xs

minimumList :: (Storable a, Ord a) => Array ShapeInt a -> Bool
minimumList =
   withNonEmpty Array.minimum $ \x xs -> x == minimum (Array.toList xs)

maximumList :: (Storable a, Ord a) => Array ShapeInt a -> Bool
maximumList =
   withNonEmpty Array.maximum $ \x xs -> x == maximum (Array.toList xs)

limitsMinimumMaximum :: (Storable a, Ord a) => Array ShapeInt a -> Bool
limitsMinimumMaximum =
   withNonEmpty Array.limits $
      \xe xs -> xe == (Array.minimum xs, Array.maximum xs)


tests :: [(String, QC.Property)]
tests =
   ("singleton", QC.property (singleton . (id :: Word16 -> Word16))) :
   ("appendTakeDrop",
      QC.forAll QC.arbitrary $ \n ->
      QC.forAll genArray $ \xs -> appendTakeDrop n xs) :
   ("takeLeftRightAppend",
      QC.forAll genArray $ \xs ->
      QC.forAll genArray $ \ys -> takeLeftRightAppend xs ys) :

   ("sum",
      QC.forAll genArray sumList) :
   ("product",
      QC.forAll genArray productList) :
   ("minimum",
      QC.forAll genArray minimumList) :
   ("maximum",
      QC.forAll genArray maximumList) :
   ("limitsMinimumMaximum",
      QC.forAll genArray limitsMinimumMaximum) :
   []