bifunctors-5.4: tests/BifunctorSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
#endif
{-|
Module: BifunctorSpec
Copyright: (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Edward Kmett
Portability: Template Haskell
@hspec@ tests for the "Data.Bifunctor.TH" module.
-}
module BifunctorSpec where
import Data.Bifunctor
import Data.Bifunctor.TH
import Data.Bifoldable
import Data.Bitraversable
import Data.Char (chr)
import Data.Functor.Classes (Eq1)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Monoid
import GHC.Exts (Int#)
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (Arbitrary)
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative (Applicative(..))
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
#endif
-------------------------------------------------------------------------------
-- Adapted from the test cases from
-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch
-- Plain data types
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
type IntFun a b = (b -> Int) -> a
data StrangeFunctions a b c
= T6 (a -> c) -- function types
| T7 (a -> (c,a)) -- functions and tuples
| T8 ((b -> a) -> c) -- continuation
| T9 (IntFun b c) -- type synonyms
data StrangeGADT a b where
T10 :: Ord d => d -> StrangeGADT c d
T11 :: Int -> StrangeGADT e Int
T12 :: c ~ Int => c -> StrangeGADT f Int
T13 :: i ~ Int => Int -> StrangeGADT h i
T14 :: k ~ Int => k -> StrangeGADT j k
T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n
data NotPrimitivelyRecursive a b
= S1 (NotPrimitivelyRecursive (a,a) (b, a))
| S2 a
| S3 b
newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b))
deriving (Arbitrary, Eq, Show)
newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))
data Universal a b
= Universal (forall b. (b,[a]))
| Universal2 (forall f. Bifunctor f => f a b)
| Universal3 (forall a. Maybe a) -- reuse a
| NotReallyUniversal (forall b. a)
data Existential a b
= forall a. ExistentialList [a]
| forall f. Bitraversable f => ExistentialFunctor (f a b)
| forall b. SneakyUseSameName (Maybe b)
data IntHash a b
= IntHash Int# Int#
| IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int))
data IntHashFun a b
= IntHashFun ((((a -> Int#) -> b) -> Int#) -> a)
-- Data families
data family StrangeFam x y z
data instance StrangeFam a b c
= T1Fam a b c
| T2Fam [a] [b] [c] -- lists
| T3Fam [[a]] [[b]] [[c]] -- nested lists
| T4Fam (c,(b,b),(c,c)) -- tuples
| T5Fam ([c],Strange a b c) -- tycons
data family StrangeFunctionsFam x y z
data instance StrangeFunctionsFam a b c
= T6Fam (a -> c) -- function types
| T7Fam (a -> (c,a)) -- functions and tuples
| T8Fam ((b -> a) -> c) -- continuation
| T9Fam (IntFun b c) -- type synonyms
data family StrangeGADTFam x y
data instance StrangeGADTFam a b where
T10Fam :: Ord d => d -> StrangeGADTFam c d
T11Fam :: Int -> StrangeGADTFam e Int
T12Fam :: c ~ Int => c -> StrangeGADTFam f Int
T13Fam :: i ~ Int => Int -> StrangeGADTFam h i
T14Fam :: k ~ Int => k -> StrangeGADTFam j k
T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n
data family NotPrimitivelyRecursiveFam x y
data instance NotPrimitivelyRecursiveFam a b
= S1Fam (NotPrimitivelyRecursive (a,a) (b, a))
| S2Fam a
| S3Fam b
data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y
newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))
deriving (Arbitrary, Eq, Show)
data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y
newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))
data family UniversalFam x y
data instance UniversalFam a b
= UniversalFam (forall b. (b,[a]))
| Universal2Fam (forall f. Bifunctor f => f a b)
| Universal3Fam (forall a. Maybe a) -- reuse a
| NotReallyUniversalFam (forall b. a)
data family ExistentialFam x y
data instance ExistentialFam a b
= forall a. ExistentialListFam [a]
| forall f. Bitraversable f => ExistentialFunctorFam (f a b)
| forall b. SneakyUseSameNameFam (Maybe b)
data family IntHashFam x y
data instance IntHashFam a b
= IntHashFam Int# Int#
| IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int))
data family IntHashFunFam x y
data instance IntHashFunFam a b
= IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)
-------------------------------------------------------------------------------
-- Plain data types
$(deriveBifunctor ''Strange)
$(deriveBifoldable ''Strange)
$(deriveBitraversable ''Strange)
$(deriveBifunctor ''StrangeFunctions)
$(deriveBifoldable ''StrangeGADT)
$(deriveBifunctor ''NotPrimitivelyRecursive)
$(deriveBifoldable ''NotPrimitivelyRecursive)
$(deriveBitraversable ''NotPrimitivelyRecursive)
$(deriveBifunctor ''OneTwoCompose)
$(deriveBifoldable ''OneTwoCompose)
$(deriveBitraversable ''OneTwoCompose)
instance (Bifunctor (f Int), Functor g) =>
Bifunctor (ComplexConstraint f g) where
bimap = $(makeBimap ''ComplexConstraint)
instance (Bifoldable (f Int), Foldable g) =>
Bifoldable (ComplexConstraint f g) where
bifoldr = $(makeBifoldr ''ComplexConstraint)
bifoldMap = $(makeBifoldMap ''ComplexConstraint)
instance (Bitraversable (f Int), Traversable g) =>
Bitraversable (ComplexConstraint f g) where
bitraverse = $(makeBitraverse ''ComplexConstraint)
$(deriveBifunctor ''Universal)
$(deriveBifunctor ''Existential)
$(deriveBifoldable ''Existential)
$(deriveBitraversable ''Existential)
$(deriveBifunctor ''IntHash)
$(deriveBifoldable ''IntHash)
$(deriveBitraversable ''IntHash)
$(deriveBifunctor ''IntHashFun)
#if MIN_VERSION_template_haskell(2,7,0)
-- Data families
$(deriveBifunctor 'T1Fam)
$(deriveBifoldable 'T2Fam)
$(deriveBitraversable 'T3Fam)
$(deriveBifunctor 'T6Fam)
$(deriveBifoldable 'T10Fam)
$(deriveBifunctor 'S1Fam)
$(deriveBifoldable 'S2Fam)
$(deriveBitraversable 'S3Fam)
$(deriveBifunctor 'OneTwoComposeFam)
$(deriveBifoldable 'OneTwoComposeFam)
$(deriveBitraversable 'OneTwoComposeFam)
instance (Bifunctor (f Int), Functor g) =>
Bifunctor (ComplexConstraintFam f g) where
bimap = $(makeBimap 'ComplexConstraintFam)
instance (Bifoldable (f Int), Foldable g) =>
Bifoldable (ComplexConstraintFam f g) where
bifoldr = $(makeBifoldr 'ComplexConstraintFam)
bifoldMap = $(makeBifoldMap 'ComplexConstraintFam)
instance (Bitraversable (f Int), Traversable g) =>
Bitraversable (ComplexConstraintFam f g) where
bitraverse = $(makeBitraverse 'ComplexConstraintFam)
$(deriveBifunctor 'UniversalFam)
$(deriveBifunctor 'ExistentialListFam)
$(deriveBifoldable 'ExistentialFunctorFam)
$(deriveBitraversable 'SneakyUseSameNameFam)
$(deriveBifunctor 'IntHashFam)
$(deriveBifoldable 'IntHashTupleFam)
$(deriveBitraversable 'IntHashFam)
$(deriveBifunctor 'IntHashFunFam)
#endif
-------------------------------------------------------------------------------
prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d))
=> (a -> c) -> (b -> d) -> p a b -> Bool
prop_BifunctorLaws f g x =
bimap id id x == x
&& first id x == x
&& second id x == x
&& bimap f g x == (first f . second g) x
prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int])) => p [Int] [Int] -> Bool
prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42])
prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Bifoldable p)
=> (a -> b) -> (a -> b)
-> (a -> z -> z) -> (a -> z -> z)
-> z -> p a a -> Bool
prop_BifoldableLaws f g h i z x =
bifold x == bifoldMap id id x
&& bifoldMap f g x == bifoldr (mappend . f) (mappend . g) mempty x
&& bifoldr h i z x == appEndo (bifoldMap (Endo . h) (Endo . i) x) z
prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Bool
prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0
prop_BitraversableLaws :: (Applicative f, Applicative g, Bitraversable p,
Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f)
=> (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e)
-> (forall x. f x -> g x) -> p a b -> Bool
prop_BitraversableLaws f g h i t x =
bitraverse (t . f) (t . g) x == (t . bitraverse f g) x
&& bitraverse Identity Identity x == Identity x
&& (Compose . fmap (bitraverse h i) . bitraverse f g) x
== bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x
prop_BitraversableEx :: (Bitraversable p, Eq (p Char Char),
Eq (p [Char] [Char]), Eq (p [Int] [Int]))
=> p [Int] [Int] -> Bool
prop_BitraversableEx = prop_BitraversableLaws
(replicate 2 . map (chr . abs))
(replicate 4 . map (chr . abs))
(++ "hello")
(++ "world")
reverse
-------------------------------------------------------------------------------
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "OneTwoCompose Maybe Either [Int] [Int]" $ do
prop "satisfies the Bifunctor laws"
(prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)
prop "satisfies the Bifoldable laws"
(prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)
prop "satisfies the Bitraversable laws"
(prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)
#if MIN_VERSION_template_haskell(2,7,0)
describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do
prop "satisfies the Bifunctor laws"
(prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)
prop "satisfies the Bifoldable laws"
(prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)
prop "satisfies the Bitraversable laws"
(prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)
#endif