BifunctorSpec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE RoleAnnotations #-}
#endif

{-# 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-2023 Edward Kmett, (C) 2015 Ryan Scott
-- License:     BSD-2-Clause OR Apache-2.0
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- 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, Show1)
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
  deriving (Functor, Foldable, Traversable)

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
  deriving Functor

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
deriving instance Foldable (StrangeGADT a)

data NotPrimitivelyRecursive a b
    = S1 (NotPrimitivelyRecursive (a,a) (b, a))
    | S2 a
    | S3 b
  deriving (Functor, Foldable, Traversable)

newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b))
  deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable)

newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))
instance (Bifunctor (f Int), Functor g) =>
    Functor (ComplexConstraint f g a) where
  fmap f (ComplexConstraint x) =
    ComplexConstraint (bimap id (\(ga,a,b) -> (ga,a,f b)) x)
instance (Bifoldable (f Int), Foldable g) =>
    Foldable (ComplexConstraint f g a) where
  foldMap f (ComplexConstraint x) =
    bifoldMap (const mempty) (\(_,_,b) -> f b) x
instance (Bitraversable (f Int), Traversable g) =>
    Traversable (ComplexConstraint f g a) where
  traverse f (ComplexConstraint x) =
    ComplexConstraint <$> bitraverse pure (\(ga,a,b) -> (ga,a,) <$> f b) x

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)
instance Functor (Universal a) where
  fmap f (Universal  x)         = Universal x
  fmap f (Universal2 x)         = Universal2 (bimap id f x)
  fmap f (Universal3 x)         = Universal3 x
  fmap f (NotReallyUniversal x) = NotReallyUniversal x

data Existential a b
    = forall a. ExistentialList [a]
    | forall f. Bitraversable f => ExistentialFunctor (f a b)
    | forall b. SneakyUseSameName (Maybe b)
instance Functor (Existential a) where
  fmap f (ExistentialList x)    = ExistentialList x
  fmap f (ExistentialFunctor x) = ExistentialFunctor (bimap id f x)
  fmap f (SneakyUseSameName x)  = SneakyUseSameName x
instance Foldable (Existential a) where
  foldMap f (ExistentialList _)    = mempty
  foldMap f (ExistentialFunctor x) = bifoldMap (const mempty) f x
  foldMap f (SneakyUseSameName _)  = mempty
instance Traversable (Existential a) where
  traverse f (ExistentialList x)    = pure $ ExistentialList x
  traverse f (ExistentialFunctor x) = ExistentialFunctor <$> bitraverse pure f x
  traverse f (SneakyUseSameName x)  = pure $ SneakyUseSameName x

data IntHash a b
    = IntHash Int# Int#
    | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int))
  deriving (Functor, Foldable, Traversable)

data IntHashFun a b
    = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a)
  deriving Functor

data Empty1 a b
  deriving (Functor, Foldable, Traversable)

data Empty2 a b
  deriving (Functor, Foldable, Traversable)
#if __GLASGOW_HASKELL__ >= 708
type role Empty2 nominal nominal
#endif

data TyCon81 a b
    = TyCon81a (forall c. c -> (forall d. a -> d) -> a)
    | TyCon81b (Int -> forall c. c -> b)
instance Functor (TyCon81 a) where
  fmap f (TyCon81a g) = TyCon81a g
  fmap f (TyCon81b g) = TyCon81b (\x y -> f (g x y))

type family F :: * -> * -> *
type instance F = Either

data TyCon82 a b = TyCon82 (F a b)
  deriving (Functor, Foldable, Traversable)

-- 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
  deriving (Functor, Foldable, Traversable)

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
  deriving Functor

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
deriving instance Foldable (StrangeGADTFam a)

data family   NotPrimitivelyRecursiveFam x y
data instance NotPrimitivelyRecursiveFam a b
    = S1Fam (NotPrimitivelyRecursive (a,a) (b, a))
    | S2Fam a
    | S3Fam b
  deriving (Functor, Foldable, Traversable)

data family      OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y
newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))
  deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable)

data family      ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y
newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))
instance (Bifunctor (f Int), Functor g) =>
    Functor (ComplexConstraintFam f g a) where
  fmap f (ComplexConstraintFam x) =
    ComplexConstraintFam (bimap id (\(ga,a,b) -> (ga,a,f b)) x)
instance (Bifoldable (f Int), Foldable g) =>
    Foldable (ComplexConstraintFam f g a) where
  foldMap f (ComplexConstraintFam x) =
    bifoldMap (const mempty) (\(_,_,b) -> f b) x
instance (Bitraversable (f Int), Traversable g) =>
    Traversable (ComplexConstraintFam f g a) where
  traverse f (ComplexConstraintFam x) =
    ComplexConstraintFam <$> bitraverse pure (\(ga,a,b) -> (ga,a,) <$> f b) x

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)
instance Functor (UniversalFam a) where
  fmap f (UniversalFam  x)         = UniversalFam x
  fmap f (Universal2Fam x)         = Universal2Fam (bimap id f x)
  fmap f (Universal3Fam x)         = Universal3Fam x
  fmap f (NotReallyUniversalFam x) = NotReallyUniversalFam x

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)
instance Functor (ExistentialFam a) where
  fmap f (ExistentialListFam x)    = ExistentialListFam x
  fmap f (ExistentialFunctorFam x) = ExistentialFunctorFam (bimap id f x)
  fmap f (SneakyUseSameNameFam x)  = SneakyUseSameNameFam x
instance Foldable (ExistentialFam a) where
  foldMap f (ExistentialListFam _)    = mempty
  foldMap f (ExistentialFunctorFam x) = bifoldMap (const mempty) f x
  foldMap f (SneakyUseSameNameFam _)  = mempty
instance Traversable (ExistentialFam a) where
  traverse f (ExistentialListFam x)    = pure $ ExistentialListFam x
  traverse f (ExistentialFunctorFam x) = ExistentialFunctorFam <$> bitraverse pure f x
  traverse f (SneakyUseSameNameFam x)  = pure $ SneakyUseSameNameFam x

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))
  deriving (Functor, Foldable, Traversable)

data family   IntHashFunFam x y
data instance IntHashFunFam a b
    = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)
  deriving Functor

data family   TyFamily81 x y
data instance TyFamily81 a b
    = TyFamily81a (forall c. c -> (forall d. a -> d) -> a)
    | TyFamily81b (Int -> forall c. c -> b)
instance Functor (TyFamily81 a) where
  fmap f (TyFamily81a g) = TyFamily81a g
  fmap f (TyFamily81b g) = TyFamily81b (\x y -> f (g x y))

data family   TyFamily82 x y
data instance TyFamily82 a b = TyFamily82 (F a b)
  deriving (Functor, Foldable, Traversable)

-------------------------------------------------------------------------------

-- 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)

bifoldlComplexConstraint
  :: (Bifoldable (f Int), Foldable g)
  => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c
bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint)

bifoldComplexConstraint
  :: (Bifoldable (f Int), Foldable g, Monoid m)
  => ComplexConstraint f g m m -> m
bifoldComplexConstraint = $(makeBifold ''ComplexConstraint)

instance (Bitraversable (f Int), Traversable g) =>
  Bitraversable (ComplexConstraint f g) where
    bitraverse = $(makeBitraverse ''ComplexConstraint)

bisequenceAComplexConstraint
  :: (Bitraversable (f Int), Traversable g, Applicative t)
  => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b)
bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint)

$(deriveBifunctor     ''Universal)

$(deriveBifunctor     ''Existential)
$(deriveBifoldable    ''Existential)
$(deriveBitraversable ''Existential)

$(deriveBifunctor     ''IntHash)
$(deriveBifoldable    ''IntHash)
$(deriveBitraversable ''IntHash)

$(deriveBifunctor     ''IntHashFun)

$(deriveBifunctor     ''Empty1)
$(deriveBifoldable    ''Empty1)
$(deriveBitraversable ''Empty1)

-- Use EmptyCase here
$(deriveBifunctorOptions     defaultOptions{emptyCaseBehavior = True} ''Empty2)
$(deriveBifoldableOptions    defaultOptions{emptyCaseBehavior = True} ''Empty2)
$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2)

$(deriveBifunctor     ''TyCon81)

$(deriveBifunctor     ''TyCon82)
$(deriveBifoldable    ''TyCon82)
$(deriveBitraversable ''TyCon82)

#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)

bifoldlComplexConstraintFam
  :: (Bifoldable (f Int), Foldable g)
  => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c
bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam)

bifoldComplexConstraintFam
  :: (Bifoldable (f Int), Foldable g, Monoid m)
  => ComplexConstraintFam f g m m -> m
bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam)

instance (Bitraversable (f Int), Traversable g) =>
  Bitraversable (ComplexConstraintFam f g) where
    bitraverse = $(makeBitraverse 'ComplexConstraintFam)

bisequenceAComplexConstraintFam
  :: (Bitraversable (f Int), Traversable g, Applicative t)
  => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b)
bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam)

$(deriveBifunctor     'UniversalFam)

$(deriveBifunctor     'ExistentialListFam)
$(deriveBifoldable    'ExistentialFunctorFam)
$(deriveBitraversable 'SneakyUseSameNameFam)

$(deriveBifunctor     'IntHashFam)
$(deriveBifoldable    'IntHashTupleFam)
$(deriveBitraversable 'IntHashFam)

$(deriveBifunctor     'IntHashFunFam)

$(deriveBifunctor     'TyFamily81a)

$(deriveBifunctor     'TyFamily82)
$(deriveBifoldable    'TyFamily82)
$(deriveBitraversable 'TyFamily82)
#endif

-------------------------------------------------------------------------------

prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d), Show (p a b), Show (p c d))
                   => (a -> c) -> (b -> d) -> p a b -> Expectation
prop_BifunctorLaws f g x = do
    bimap  id id x `shouldBe` x
    first  id    x `shouldBe` x
    second id    x `shouldBe` x
    bimap  f  g  x `shouldBe` (first f . second g) x

prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation
prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42])

prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z,
                        Monoid a, Monoid b, Bifoldable p)
                => (a -> b) -> (a -> b)
                -> (a -> z -> z) -> (a -> z -> z)
                -> z -> p a a -> Expectation
prop_BifoldableLaws f g h i z x = do
    bifold        x `shouldBe` bifoldMap id id x
    bifoldMap f g x `shouldBe` bifoldr (mappend . f) (mappend . g) mempty x
    bifoldr h i z x `shouldBe` appEndo (bifoldMap (Endo . h) (Endo . i) x) z

prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Expectation
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,
                           Show (g (p c c)), Show (p a b), Show (p d e), Show1 f)
                       => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e)
                       -> (forall x. f x -> g x) -> p a b -> Expectation
prop_BitraversableLaws f g h i t x = do
    bitraverse (t . f) (t . g)   x `shouldBe` (t . bitraverse f g) x
    bitraverse Identity Identity x `shouldBe` Identity x
    (Compose . fmap (bitraverse h i) . bitraverse f g) x
      `shouldBe` 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]),
                        Show (p Char Char), Show (p [Char] [Char]), Show (p [Int] [Int]))
                        => p [Int] [Int] -> Expectation
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] -> Expectation)
        prop "satisfies the Bifoldable laws"
            (prop_BifoldableEx    :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)
        prop "satisfies the Bitraversable laws"
            (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation)
#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] -> Expectation)
        prop "satisfies the Bifoldable laws"
            (prop_BifoldableEx    :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)
        prop "satisfies the Bitraversable laws"
            (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation)
#endif