{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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 -Wno-unused-foralls #-}
#endif

{-|
Module:      FunctorSpec
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

@hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances.
-}
module FunctorSpec where

import Data.Char (chr)
import Data.Foldable (fold)
import Data.Deriving
import Data.Functor.Classes (Eq1)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Monoid
import Data.Orphans ()

import GHC.Exts (Int#)

import Prelude ()
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

-- 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 (Either (f (g a)) (f (g 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. Functor (f a) => f a b)
    | Universal3 (forall a. Maybe a) -- reuse a
    | NotReallyUniversal (forall b. a)

data Existential a b
    = forall a. ExistentialList [a]
    | forall f. Traversable (f a) => 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 Empty1 a
data Empty2 a
#if __GLASGOW_HASKELL__ >= 708
type role Empty2 nominal
#endif

-- 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 (Either (f (g a)) (f (g 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. Functor (f a) => 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. Traversable (f a) => 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

$(deriveFunctor     ''Strange)
$(deriveFoldable    ''Strange)
$(deriveTraversable ''Strange)

$(deriveFunctor     ''StrangeFunctions)
$(deriveFoldable    ''StrangeGADT)

$(deriveFunctor     ''NotPrimitivelyRecursive)
$(deriveFoldable    ''NotPrimitivelyRecursive)
$(deriveTraversable ''NotPrimitivelyRecursive)

$(deriveFunctor     ''OneTwoCompose)
$(deriveFoldable    ''OneTwoCompose)
$(deriveTraversable ''OneTwoCompose)

instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where
    fmap      = $(makeFmap      ''ComplexConstraint)
instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where
    foldr     = $(makeFoldr     ''ComplexConstraint)
    foldMap   = $(makeFoldMap   ''ComplexConstraint)
    fold      = $(makeFold      ''ComplexConstraint)
    foldl     = $(makeFoldl     ''ComplexConstraint)
instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where
    traverse  = $(makeTraverse  ''ComplexConstraint)
    sequenceA = $(makeSequenceA ''ComplexConstraint)
    mapM      = $(makeMapM      ''ComplexConstraint)
    sequence  = $(makeSequence  ''ComplexConstraint)

$(deriveFunctor     ''Universal)

$(deriveFunctor     ''Existential)
$(deriveFoldable    ''Existential)
$(deriveTraversable ''Existential)

$(deriveFunctor     ''IntHash)
$(deriveFoldable    ''IntHash)
$(deriveTraversable ''IntHash)

$(deriveFunctor     ''IntHashFun)

$(deriveFunctor     ''Empty1)
$(deriveFoldable    ''Empty1)
$(deriveTraversable ''Empty1)

-- Use EmptyCase here
$(deriveFunctorOptions     defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2)
$(deriveFoldableOptions    defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2)
$(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2)

#if MIN_VERSION_template_haskell(2,7,0)
-- Data families

$(deriveFunctor     'T1Fam)
$(deriveFoldable    'T2Fam)
$(deriveTraversable 'T3Fam)

$(deriveFunctor     'T6Fam)
$(deriveFoldable    'T10Fam)

$(deriveFunctor     'S1Fam)
$(deriveFoldable    'S2Fam)
$(deriveTraversable 'S3Fam)

$(deriveFunctor     'OneTwoComposeFam)
$(deriveFoldable    'OneTwoComposeFam)
$(deriveTraversable 'OneTwoComposeFam)

instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where
    fmap      = $(makeFmap      'ComplexConstraintFam)
instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where
    foldr     = $(makeFoldr     'ComplexConstraintFam)
    foldMap   = $(makeFoldMap   'ComplexConstraintFam)
    fold      = $(makeFold      'ComplexConstraintFam)
    foldl     = $(makeFoldl     'ComplexConstraintFam)
instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where
    traverse  = $(makeTraverse  'ComplexConstraintFam)
    sequenceA = $(makeSequenceA 'ComplexConstraintFam)
    mapM      = $(makeMapM      'ComplexConstraintFam)
    sequence  = $(makeSequence  'ComplexConstraintFam)

$(deriveFunctor     'UniversalFam)

$(deriveFunctor     'ExistentialListFam)
$(deriveFoldable    'ExistentialFunctorFam)
$(deriveTraversable 'SneakyUseSameNameFam)

$(deriveFunctor     'IntHashFam)
$(deriveFoldable    'IntHashTupleFam)
$(deriveTraversable 'IntHashFam)

$(deriveFunctor     'IntHashFunFam)
#endif

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

prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c))
                 => (b -> c) -> (a -> b) -> f a -> Bool
prop_FunctorLaws f g x =
       fmap id      x == x
    && fmap (f . g) x == (fmap f . fmap g) x

prop_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool
prop_FunctorEx = prop_FunctorLaws reverse (++ [42])

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

prop_FoldableEx :: Foldable f => f [Int] -> Bool
prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0

prop_TraversableLaws :: forall t f g a b c.
                        (Applicative f, Applicative g, Traversable t,
                         Eq (t (f a)),  Eq (g (t a)),  Eq (g (t b)),
                         Eq (t a),      Eq (t c),      Eq1 f, Eq1 g)
                       => (a -> f b) -> (b -> f c)
                       -> (forall x. f x -> g x) -> t a -> Bool
prop_TraversableLaws f g t x =
       (t . traverse f)  x == traverse (t . f)   x
    && traverse Identity x == Identity           x
    && traverse (Compose . fmap g . f) x
         == (Compose . fmap (traverse g) . traverse f) x

    && (t . sequenceA)             y == (sequenceA . fmap t) y
    && (sequenceA . fmap Identity) y == Identity             y
    && (sequenceA . fmap Compose)  z
         == (Compose . fmap sequenceA . sequenceA) z
  where
    y :: t (f a)
    y = fmap pure x

    z :: t (f (g a))
    z = fmap (fmap pure) y

prop_TraversableEx :: (Traversable t, Eq (t [[Int]]),
                       Eq (t [Int]), Eq (t String), Eq (t Char))
                   => t [Int] -> Bool
prop_TraversableEx = prop_TraversableLaws
    (replicate 2 . map (chr . abs))
    (++ "Hello")
    reverse

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

main :: IO ()
main = hspec spec

spec :: Spec
spec = parallel $ do
    describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do
        prop "satisfies the Functor laws"
            (prop_FunctorEx     :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)
        prop "satisfies the Foldable laws"
            (prop_FoldableEx    :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)
        prop "satisfies the Traversable laws"
            (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)
#if MIN_VERSION_template_haskell(2,7,0)
    describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do
        prop "satisfies the Functor laws"
            (prop_FunctorEx     :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)
        prop "satisfies the Foldable laws"
            (prop_FoldableEx    :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)
        prop "satisfies the Traversable laws"
            (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)
#endif