Test.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Fold.Test
( tests
) where

import Fresnel.Fold
import Fresnel.Ixed
import Test.Group
import Test.QuickCheck

prop_union_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property
prop_union_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getUnion (Union a <> (Union b <> Union c))) as === toListOf (getUnion ((Union a <> Union b) <> Union c)) as

prop_union_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property
prop_union_monoid_identity (ArbFold a) as =
  classifyList as $
  toListOf (getUnion (mempty <> Union a)) as === toListOf a as .&&. toListOf (getUnion (Union a <> mempty)) as === toListOf a as


prop_failover_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property
prop_failover_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getFailover (Failover a <> (Failover b <> Failover c))) as === toListOf (getFailover ((Failover a <> Failover b) <> Failover c)) as

prop_failover_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property
prop_failover_monoid_identity (ArbFold a) as = classifyList as $ toListOf (getFailover (mempty <> Failover a)) as === toListOf a as .&&. toListOf (getFailover (Failover a <> mempty)) as === toListOf a as


prop_iterated (Fn f) a (MostlyPositive n) = classifyInt n $ take n (toListOf (iterated f) a) === take n (iterate f a)


prop_filtered (Fn p) as
  = classify (not (any p as)) "reject all"
  . classify (all p as) "accept all"
  . classifyList as
  $ toListOf (folded.filtered p) as === filter p as


prop_repeated (MostlyPositive n) a = classifyInt n $ take n (toListOf repeated a) === take n (repeat a)


prop_replicated (MostlyPositive n) a = classifyInt n $ toListOf (replicated n) a === replicate n a


prop_cycled (NonEmpty as) (NonNegative n) = classifyList as $ take n (toListOf (cycled folded) as) === take n (cycle as)


prop_takingWhile (Fn p) as = classifyList as $ toListOf (takingWhile p folded) as === takeWhile p as


classifyList :: Testable prop => [a] -> prop -> Property
classifyList as = classify (null as) "empty" . classify (length as == 1) "singleton"

classifyInt :: Testable prop => Int -> prop -> Property
classifyInt n = classify (n == 0) "zero" . classify (n < 0) "negative"


newtype ArbFold a = ArbFold (Fold [a] a)

instance Show a => Show (ArbFold a) where
  showsPrec _ (ArbFold fold) = showList (toListOf fold []) -- FIXME: this is a bad instance

instance Arbitrary a => Arbitrary (ArbFold a) where
  arbitrary = oneof
    [ pure (ArbFold folded)
    , pure (ArbFold ignored)
    , ixed <$> arbitrary
    ]
    where
    ixed :: Int -> ArbFold a
    ixed i = ArbFold (ix i)


newtype MostlyPositive a = MostlyPositive { getMostlyPositive :: a }
  deriving (Eq, Num, Ord, Show)

instance (Arbitrary a, Num a, Ord a) => Arbitrary (MostlyPositive a) where
  arbitrary = MostlyPositive <$> frequency
    [ (90, getPositive <$> arbitrary)
    , (5, pure 0)
    , (5, getNegative <$> arbitrary)
    ]

  shrink (MostlyPositive a) = [MostlyPositive a' | a' <- shrink a, signum a' == signum a]


pure []

tests :: Entry
tests = $deriveGroup