quickcheck-classes-0.3: test/Spec.hs

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

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

import qualified Data.Vector as V

import Test.QuickCheck.Classes

main :: IO ()
main = do
  putStrLn "Testing properties for common typeclasses"
  r <- flip foldlMapM allPropsApplied $ \(typeName,laws) -> do
    putStrLn $ "------------"
    putStrLn $ "-- " ++ typeName
    putStrLn $ "------------"
    flip foldlMapM laws $ \(Laws typeClassName properties) -> do
      flip foldlMapM properties $ \(name,p) -> do
        putStr (typeClassName ++ ": " ++ name ++ " ")
        r <- quickCheckResult p
        return $ case r of
          Success _ _ _ -> Good
          _ -> Bad
  putStrLn ""
  case r of
    Good -> putStrLn "All tests succeeded"
    Bad -> putStrLn "One or more tests failed"

data Status = Bad | Good

instance Monoid Status where
  mempty = Good
  mappend Good x = x
  mappend Bad _ = Bad

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 (Proxy :: Proxy Maybe))
  , ("List",allHigherLaws (Proxy :: Proxy []))
#endif
  , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))])
  ]

allLaws :: forall a. (Num a, Prim a, Storable a, Ord a, Arbitrary a, Show a, Read a, ToJSON a, FromJSON a) => Proxy a -> [Laws]
allLaws p = 
  [ primLaws p
  , storableLaws p
  , monoidLaws (Proxy :: Proxy (Sum a))
  , showReadLaws p
  , jsonLaws p
  , eqLaws p
  , ordLaws p
  ]

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

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

-- This type is 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]
  deriving (Eq,Show,Arbitrary,Arbitrary1,Eq1,Show1)

instance Foldable Rouge where
  foldMap f (Rouge xs) = foldMap f xs
  foldl f x (Rouge xs) = foldl f x xs
  foldl' f x (Rouge xs) = foldl f x xs
  foldr' f x (Rouge xs) = foldr f x xs

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

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