{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-|
Module: FoldableSpec
Copyright: (C) 2015 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Template Haskell
@hspec@ tests for the "Data.Foldable.Deriving" module.
-}
module FoldableSpec where
import Data.Foldable (fold)
import Data.Foldable.Deriving
import Data.Monoid
import Prelude.Compat
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (Arbitrary)
-------------------------------------------------------------------------------
-- Adapted from the test cases from
-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch
data Strange a b c
= T1 a b c
| T2 [a] [b] [c] -- lists
| T3 [[a]] [[b]] [[c]] -- nested lists
| T4 (c,(b,b),(c,c)) -- tuples
| T5 ([c],Strange a b c) -- tycons
data StrangeGADT a b where
T10 :: Ord b => b -> StrangeGADT a b
T11 :: Int -> StrangeGADT a Int
T12 :: c ~ Int => c -> StrangeGADT a Int
T13 :: b ~ Int => Int -> StrangeGADT a b
T14 :: b ~ Int => b -> StrangeGADT a b
T15 :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADT a b
data NotPrimitivelyRecursive a b
= S1 (NotPrimitivelyRecursive (a,a) (b, a))
| S2 a
| S3 b
newtype Compose f g a = Compose (f (g a))
deriving (Arbitrary, Eq, Show)
newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g b, a, b))
type Flip f a b = f b a
data Existential a b
= forall a. ExistentialList [a]
| forall f. Foldable (f a) => ExistentialFoldable (Flip f b a)
| forall b. SneakyUseSameName (Maybe b)
-------------------------------------------------------------------------------
$(deriveFoldable ''Strange)
$(deriveFoldable ''StrangeGADT)
$(deriveFoldable ''NotPrimitivelyRecursive)
$(deriveFoldable ''Compose)
instance (Foldable (f Int Int), Foldable g) =>
Foldable (ComplexConstraint f g a) where
foldr = $(makeFoldr ''ComplexConstraint)
foldMap = $(makeFoldMap ''ComplexConstraint)
$(deriveFoldable ''Existential)
-------------------------------------------------------------------------------
prop_FoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Foldable f)
=> (a -> b) -> (a -> z -> z) -> z -> f a -> Bool
prop_FoldableLaws f h z x =
fold x == foldMap id x
&& foldMap f x == foldr (mappend . f) mempty x
&& foldr h z x == appEndo (foldMap (Endo . h) x) z
-------------------------------------------------------------------------------
main :: IO ()
main = hspec spec
spec :: Spec
spec =
describe "Compose Maybe Maybe [Int]" $
prop "satisfies the Foldable laws"
(prop_FoldableLaws
reverse
((+) . length)
0
:: Compose Maybe Maybe [Int] -> Bool)