{-# language ExistentialQuantification #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language ScopedTypeVariables #-}
{-# language UndecidableInstances #-}

module Main (main) where

import Data.Functor.Identity (Identity(..))
import Data.Monoid
import Data.Primitive
import Prelude
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import qualified Data.Maybe as P
import qualified Data.Primitive.Contiguous as C
import qualified GHC.Exts as Exts
import qualified Prelude as P
import qualified Data.Either as P
import qualified Data.List as P
import qualified Data.Vector as V

main :: IO ()
main = unitTests

unitTests :: IO ()
unitTests = mapM_ testC
  [ quiet "Contiguous.filter = Data.List.filter" prop_filter
  , quiet "Contiguous.mapMaybe = Data.Maybe.mapMaybe" prop_mapMaybe
  , quiet "Reverse: reverse . reverse = id" prop_reverse1
  , quiet "Contiguous.reverse = Data.List.reverse" prop_reverse2
  , quiet "Contiguous.map = Data.List.map" prop_map
  , quiet "Contiguous.unfoldr = Data.List.unfoldr" prop_unfoldr
  , quiet "Contiguous.unfoldrN = Data.Vector.unfoldrN" prop_unfoldrN
  , quiet "Contiguous.traverse = Data.Traversable.traverse" prop_traverse
  , quiet "Contiguous.find = Data.Foldable.find" prop_find
  , quiet "Contiguous.scanl = Data.List.scanl" prop_scanl
  , quiet "Contiguous.scanl' = Data.List.scanl'" prop_scanl'
  , quiet "Contiguous.prescanl = Data.Vector.prescanl" prop_prescanl
  , quiet "Contiguous.prescanl' = Data.Vector.prescanl'" prop_prescanl'
  , quiet "Contiguous.generate = Data.Vector.generate" prop_generate
  , quiet "Contiguous.generateM = Data.Vector.generateM" prop_generateM
  , quiet "Contiguous.minimum = Data.Foldable.minimum" prop_minimum
  , quiet "Contiguous.maximum = Data.Foldable.maximum" prop_maximum
  , quiet "Contiguous.zipWith = Data.List.zipWith" prop_zipWith
  , quiet "Contiguous.zip = Data.List.zip" prop_zip
  , quiet "Contiguous.lefts = Data.Either.lefts" prop_lefts
  , quiet "Contiguous.rights = Data.Either.rights" prop_rights
  , quiet "Contiguous.partitionEithers = Data.Either.partitionEithers" prop_partitionEithers
  ]

-- Verbosity with which to run tests.
data Verbosity = Quiet | Verbose

-- | Hide the prop type.
data Prop = forall prop. Testable prop => Prop prop


-- hack to let us get away with stuffing different
-- prop types in a list
data CTest = CTest
  { _verbosity :: Verbosity
  , _label :: String
  , _prop :: Prop
  }

-- quiet output of a test
quiet :: Testable prop => String -> prop -> CTest
quiet l p = CTest Quiet l (Prop p)

-- verbose output of a test
-- Useful for failing tests
_verbose :: Testable prop => String -> prop -> CTest
_verbose l p = CTest Verbose l (Prop p)

testC :: CTest -> IO ()
testC (CTest v lbl (Prop p)) = do
  putStrLn $ P.replicate (length lbl + 6) '-'
  putStrLn $ "-- " ++ lbl ++ " --"
  putStrLn $ P.replicate (length lbl + 6) '-'
  putStr "\n"
  ($ p) $ case v of { Verbose -> verboseCheck; Quiet -> quickCheck }
  putStr "\n"

newtype Arr = Arr (Array L)
  deriving (Eq,Show)

newtype L = L [Int]
  deriving (Eq,Ord,Exts.IsList)

instance Show L where
  show (L x) = show x

instance Arbitrary L where
  arbitrary = do
    j <- choose (1,6)
    fmap L $ vectorOf j arbitrary

instance Arbitrary Arr where
  arbitrary = do
    k <- choose (2,20)
    fmap (Arr . Exts.fromList) $ vectorOf k arbitrary
  shrink (Arr xs) = fmap Arr (fmap Exts.fromList $ shrink $ Exts.toList xs)

mean :: forall t a. (Foldable t, Integral a) => t a -> a
mean xs =
  let (sum_ :: Sum a,len_ :: Sum a) = foldMap (\x -> (Sum x, Sum 1)) xs
  in (round :: Double -> a) $ (fromIntegral (getSum sum_) / fromIntegral (getSum len_))

prop_filter :: Arr -> Property
prop_filter (Arr arr) = property $
  let arrList = C.toList arr
      p = \(L xs) -> all even xs
   in P.filter p arrList == C.toList (C.filter p arr)

prop_mapMaybe :: Arr -> Property
prop_mapMaybe (Arr arr) = property $
  let arrList = C.toList arr
      p = \(L xs) -> if all even xs then Just () else Nothing
   in P.mapMaybe p arrList == C.toList (C.mapMaybe p arr :: Array ())

prop_reverse1 :: Arr -> Property
prop_reverse1 (Arr arr) = property $
  C.reverse (C.reverse arr) == arr

prop_reverse2 :: Arr -> Property
prop_reverse2 (Arr arr) = property $
  let arrList = C.toList arr
   in P.reverse arrList == C.toList (C.reverse arr)

prop_map :: Arr -> Property
prop_map (Arr arr) = property $
  let arrList = C.toList arr
      f = \(L xs) -> mean xs
   in P.map f arrList == C.toList (C.map f arr :: Array Int)

prop_unfoldr :: Property
prop_unfoldr = property $
  let f = \n -> if n == 0 then Nothing else Just (n,n-1)
      sz = 10
   in P.unfoldr f sz == C.toList (C.unfoldr f sz :: Array Int)

prop_unfoldrN :: Property
prop_unfoldrN = property $
  let f = \n -> if n == 0 then Nothing else Just (n,n-1)
      sz = 100
   in V.toList (V.unfoldrN sz f 10) == C.toList (C.unfoldrN sz f 10 :: Array Int)

prop_traverse :: Arr -> Property
prop_traverse (Arr arr) = property $
  let arrList = C.toList arr
      f = \(L xs) -> Identity (sum xs)
   in runIdentity (P.traverse f arrList) == C.toList (runIdentity (C.traverse f arr :: Identity (Array Int)))

prop_generate :: Property
prop_generate = property $
  let f = \i -> if even i then Just i else Nothing
  in V.toList (V.generate 20 f) == C.toList (C.generate 20 f :: Array (Maybe Int))

prop_generateM :: Property
prop_generateM = property $
  let f = \i -> if even i then Just i else Nothing
  in fmap V.toList (V.generateM 20 f) == fmap C.toList (C.generateM 20 f :: Maybe (Array Int))

{-
prop_postscanl :: Arr -> Property
prop_postscanl (Arr arr) = property $
  let arrList = V.fromList (C.toList arr)
      f = \b (L a) -> b ++ a
  in V.toList (V.postscanl f [] arrList) == C.toList (C.postscanl f [] arr :: Array [Int])
-}

prop_prescanl :: Arr -> Property
prop_prescanl (Arr arr) = property $
  let arrList = V.fromList (C.toList arr)
      f = \b (L a) -> b ++ a
  in V.toList (V.prescanl f [] arrList) == C.toList (C.prescanl f [] arr :: Array [Int])

prop_prescanl' :: Arr -> Property
prop_prescanl' (Arr arr) = property $
  let arrList = V.fromList (C.toList arr)
      f = \b (L a) -> b ++ a
  in V.toList (V.prescanl' f [] arrList) == C.toList (C.prescanl' f [] arr :: Array [Int])

prop_find :: Arr -> Property
prop_find (Arr arr) = property $
  let arrList = C.toList arr
      f = \(L xs) -> even (sum xs)
   in P.find f arrList == C.find f arr

prop_zipWith :: Arr -> Arr -> Property
prop_zipWith (Arr arr1) (Arr arr2) = property $
  let arrList1 = C.toList arr1
      arrList2 = C.toList arr2
      f = \(L xs) (L ys) -> xs ++ ys
  in P.zipWith f arrList1 arrList2 == C.toList (C.zipWith f arr1 arr2 :: Array [Int])

prop_zip :: Arr -> Arr -> Property
prop_zip (Arr arr1) (Arr arr2) = property $
  let arrList1 = C.toList arr1
      arrList2 = C.toList arr2
  in P.zip arrList1 arrList2 == C.toList (C.zip arr1 arr2 :: Array (L, L))
prop_scanl :: Arr -> Property
prop_scanl (Arr arr) = property $
  let arrList = C.toList arr
      f = \b (L a) -> b ++ a
  in P.scanl f [] arrList == C.toList (C.scanl f [] arr :: Array [Int])

prop_scanl' :: Arr -> Property
prop_scanl' (Arr arr) = property $
  let arrList = C.toList arr
      f = \b (L a) -> b ++ a
  in P.scanl' f [] arrList == C.toList (C.scanl' f [] arr :: Array [Int])

prop_partitionEithers :: Array' (Either Int Bool) -> Property
prop_partitionEithers (Array' arr) = property $
  let arrList = C.toList arr
      rhs = case C.partitionEithers arr of (as,bs) -> (C.toList as, C.toList bs)
  in P.partitionEithers arrList == rhs

prop_rights :: Array' (Either Int Bool) -> Property
prop_rights (Array' arr) = property $
  let arrList = C.toList arr
  in P.rights arrList == C.toList (C.rights arr)

prop_lefts :: Array' (Either Int Bool) -> Property
prop_lefts (Array' arr) = property $
  let arrList = C.toList arr
  in P.lefts arrList == C.toList (C.lefts arr)

prop_minimum :: Arr -> Property
prop_minimum (Arr arr) = property $
  let arrList = C.toList arr
  in Just (minimum arrList) == C.minimum arr

prop_maximum :: Arr -> Property
prop_maximum (Arr arr) = property $
  let arrList = C.toList arr
  in Just (maximum arrList) == C.maximum arr

newtype Array' a = Array' { getArray' :: Array a }
  deriving (Eq, Show, Exts.IsList)

instance Arbitrary a => Arbitrary (Array' a) where
  arbitrary = do
    k <- choose (2,20)
    fmap Exts.fromList $ vectorOf k arbitrary
  shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs

-- Get around quickcheck not generating multiple arrays
--newtype GenArrM = GenArr { getGenArrM :: Array Int }
--  deriving (Eq, Show, Exts.IsList)

--instance Arbitrary GenArrM where
--  arbitrary = do
--    k <- choose (2,20)
--    GenArrM <$> C.generateM k (const arbitrary)
--  shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs