quickcheck-classes-0.4.0: test/Spec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Monad
import Control.Applicative
import Data.Aeson (ToJSON,FromJSON)
import Data.Bits
import Data.Foldable
import Data.Functor.Classes
import Data.Int
import Data.Monoid (Sum,Monoid,mappend,mconcat,mempty)
import Data.Primitive
import Data.Proxy
import Data.Vector (Vector)
import Data.Word
import Foreign.Storable
import Test.QuickCheck

import qualified Data.Vector as V
import qualified Data.Foldable as F

import Test.QuickCheck.Classes

main :: IO ()
main = lawsCheckMany allPropsApplied

-- Only needed to make GHC 7.4 content.
data Proxy1 (f :: * -> *) = Proxy1

allPropsApplied :: [(String,[Laws])]
allPropsApplied = 
  [ ("Int",allLaws (Proxy :: Proxy Int))
  , ("Int64",allLaws (Proxy :: Proxy Int64))
  , ("Word",allLaws (Proxy :: Proxy Word))
#if MIN_VERSION_QuickCheck(2,10,0)
  , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe))
  , ("List",allHigherLaws (Proxy1 :: Proxy1 []))
#endif
#if MIN_VERSION_base(4,7,0)
  , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))])
#endif
  ]

allLaws :: forall a.
  ( Integral a
  , Prim a
  , Storable a
  , Ord a
  , Arbitrary a
  , Show a
  , Read a
  , ToJSON a
  , FromJSON a
#if MIN_VERSION_base(4,7,0)
  , FiniteBits a
#endif
  ) => Proxy a -> [Laws]
allLaws p = 
  [ primLaws p
  , storableLaws p
  , monoidLaws (Proxy :: Proxy (Sum a))
  , showReadLaws p
  , jsonLaws p
  , eqLaws p
  , ordLaws p
  , integralLaws p
#if MIN_VERSION_base(4,7,0)
  , bitsLaws p
#endif
  ]

foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty

#if MIN_VERSION_QuickCheck(2,10,0)
allHigherLaws :: (Foldable f, Monad f, Applicative f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> [Laws]
allHigherLaws p = 
  [ functorLaws p
  , applicativeLaws p
  , monadLaws p
  , foldableLaws p
  ]
#endif

-- This type fails the laws for the strict functions
-- in Foldable. It is used just to confirm that
-- those property tests actually work.
newtype Rouge a = Rouge [a]
#if MIN_VERSION_QuickCheck(2,10,0)
  deriving (Eq,Show,Arbitrary,Arbitrary1,Eq1,Show1)
#else
  deriving (Eq,Show,Arbitrary,Eq1,Show1)
#endif

-- Note: when using base < 4.6, the Rouge type does
-- not really test anything. 
instance Foldable Rouge where
  foldMap f (Rouge xs) = F.foldMap f xs
  foldl f x (Rouge xs) = F.foldl f x xs
#if MIN_VERSION_base(4,6,0)
  foldl' f x (Rouge xs) = F.foldl f x xs
  foldr' f x (Rouge xs) = F.foldr f x xs
#endif

-------------------
-- Orphan Instances
-------------------

instance Arbitrary a => Arbitrary (Vector a) where
  arbitrary = V.fromList <$> arbitrary
  shrink v = map V.fromList (shrink (V.toList v))