{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif

#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

module Generics.Deriving.Traversable (
  -- * Generic Traversable class
    GTraversable(..)

  -- * Default method
  , gtraversedefault

  -- * Internal Traversable class
  , GTraversable'(..)

  ) where

import           Control.Applicative (Const, WrappedMonad(..), ZipList)
#if !(MIN_VERSION_base(4,8,0))
import           Control.Applicative (Applicative(..), (<$>))
#endif

import qualified Data.Monoid as Monoid (First, Last, Product, Sum)
import           Data.Monoid (Dual)

import           Generics.Deriving.Base
import           Generics.Deriving.Foldable
import           Generics.Deriving.Functor

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,6,0)
import           Data.Ord (Down)
#else
import           GHC.Exts (Down)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic traverse
--------------------------------------------------------------------------------

class GTraversable' t where
  gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)

instance GTraversable' V1 where
  gtraverse' :: (a -> f b) -> V1 a -> f (V1 b)
gtraverse' a -> f b
_ V1 a
x = V1 b -> f (V1 b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (V1 b -> f (V1 b)) -> V1 b -> f (V1 b)
forall a b. (a -> b) -> a -> b
$ case V1 a
x of
#if __GLASGOW_HASKELL__ >= 708
                            {}
#else
                            !_ -> error "Void gtraverse"
#endif

instance GTraversable' U1 where
  gtraverse' :: (a -> f b) -> U1 a -> f (U1 b)
gtraverse' a -> f b
_ U1 a
U1 = U1 b -> f (U1 b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 b
forall k (p :: k). U1 p
U1

instance GTraversable' Par1 where
  gtraverse' :: (a -> f b) -> Par1 a -> f (Par1 b)
gtraverse' a -> f b
f (Par1 a
a) = b -> Par1 b
forall p. p -> Par1 p
Par1 (b -> Par1 b) -> f b -> f (Par1 b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

instance GTraversable' (K1 i c) where
  gtraverse' :: (a -> f b) -> K1 i c a -> f (K1 i c b)
gtraverse' a -> f b
_ (K1 c
a) = K1 i c b -> f (K1 i c b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> K1 i c b
forall k i c (p :: k). c -> K1 i c p
K1 c
a)

instance (GTraversable f) => GTraversable' (Rec1 f) where
  gtraverse' :: (a -> f b) -> Rec1 f a -> f (Rec1 f b)
gtraverse' a -> f b
f (Rec1 f a
a) = f b -> Rec1 f b
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f b -> Rec1 f b) -> f (f b) -> f (Rec1 f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse a -> f b
f f a
a

instance (GTraversable' f) => GTraversable' (M1 i c f) where
  gtraverse' :: (a -> f b) -> M1 i c f a -> f (M1 i c f b)
gtraverse' a -> f b
f (M1 f a
a) = f b -> M1 i c f b
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f b -> M1 i c f b) -> f (f b) -> f (M1 i c f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f f a
a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where
  gtraverse' :: (a -> f b) -> (:+:) f g a -> f ((:+:) f g b)
gtraverse' a -> f b
f (L1 f a
a) = f b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f b -> (:+:) f g b) -> f (f b) -> f ((:+:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f f a
a
  gtraverse' a -> f b
f (R1 g a
a) = g b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g b -> (:+:) f g b) -> f (g b) -> f ((:+:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f g a
a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where
  gtraverse' :: (a -> f b) -> (:*:) f g a -> f ((:*:) f g b)
gtraverse' a -> f b
f (f a
a :*: g a
b) = f b -> g b -> (:*:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f b -> g b -> (:*:) f g b) -> f (f b) -> f (g b -> (:*:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f f a
a f (g b -> (:*:) f g b) -> f (g b) -> f ((:*:) f g b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f g a
b

instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where
  gtraverse' :: (a -> f b) -> (:.:) f g a -> f ((:.:) f g b)
gtraverse' a -> f b
f (Comp1 f (g a)
x) = f (g b) -> (:.:) f g b
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g b) -> (:.:) f g b) -> f (f (g b)) -> f ((:.:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g a -> f (g b)) -> f (g a) -> f (f (g b))
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse ((a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f) f (g a)
x

instance GTraversable' UAddr where
  gtraverse' :: (a -> f b) -> UAddr a -> f (UAddr b)
gtraverse' a -> f b
_ (UAddr a) = UAddr b -> f (UAddr b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Addr# -> UAddr b
forall k (p :: k). Addr# -> URec (Ptr ()) p
UAddr Addr#
a)

instance GTraversable' UChar where
  gtraverse' :: (a -> f b) -> UChar a -> f (UChar b)
gtraverse' a -> f b
_ (UChar c) = UChar b -> f (UChar b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char# -> UChar b
forall k (p :: k). Char# -> URec Char p
UChar Char#
c)

instance GTraversable' UDouble where
  gtraverse' :: (a -> f b) -> UDouble a -> f (UDouble b)
gtraverse' a -> f b
_ (UDouble d) = UDouble b -> f (UDouble b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double# -> UDouble b
forall k (p :: k). Double# -> URec Double p
UDouble Double#
d)

instance GTraversable' UFloat where
  gtraverse' :: (a -> f b) -> UFloat a -> f (UFloat b)
gtraverse' a -> f b
_ (UFloat f) = UFloat b -> f (UFloat b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float# -> UFloat b
forall k (p :: k). Float# -> URec Float p
UFloat Float#
f)

instance GTraversable' UInt where
  gtraverse' :: (a -> f b) -> UInt a -> f (UInt b)
gtraverse' a -> f b
_ (UInt i) = UInt b -> f (UInt b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int# -> UInt b
forall k (p :: k). Int# -> URec Int p
UInt Int#
i)

instance GTraversable' UWord where
  gtraverse' :: (a -> f b) -> UWord a -> f (UWord b)
gtraverse' a -> f b
_ (UWord w) = UWord b -> f (UWord b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word# -> UWord b
forall k (p :: k). Word# -> URec Word p
UWord Word#
w)

class (GFunctor t, GFoldable t) => GTraversable t where
  gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)
#if __GLASGOW_HASKELL__ >= 701
  default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                    => (a -> f b) -> t a -> f (t b)
  gtraverse = (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

  gsequenceA :: Applicative f => t (f a) -> f (t a)
  gsequenceA = (f a -> f a) -> t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse f a -> f a
forall a. a -> a
id

  gmapM :: Monad m => (a -> m b) -> t a -> m (t b)
  gmapM a -> m b
f = WrappedMonad m (t b) -> m (t b)
forall (m :: * -> *) a. WrappedMonad m a -> m a
unwrapMonad (WrappedMonad m (t b) -> m (t b))
-> (t a -> WrappedMonad m (t b)) -> t a -> m (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> WrappedMonad m b) -> t a -> WrappedMonad m (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse (m b -> WrappedMonad m b
forall (m :: * -> *) a. m a -> WrappedMonad m a
WrapMonad (m b -> WrappedMonad m b) -> (a -> m b) -> a -> WrappedMonad m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f)

  gsequence :: Monad m => t (m a) -> m (t a)
  gsequence = (m a -> m a) -> t (m a) -> m (t a)
forall (t :: * -> *) (m :: * -> *) a b.
(GTraversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
gmapM m a -> m a
forall a. a -> a
id

gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                 => (a -> f b) -> t a -> f (t b)
gtraversedefault :: (a -> f b) -> t a -> f (t b)
gtraversedefault a -> f b
f t a
x = Rep1 t b -> t b
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 t b -> t b) -> f (Rep1 t b) -> f (t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Rep1 t a -> f (Rep1 t b)
forall (t :: * -> *) (f :: * -> *) a b.
(GTraversable' t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraverse' a -> f b
f (t a -> Rep1 t a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t a
x)

-- Base types instances
instance GTraversable ((,) a) where
  gtraverse :: (a -> f b) -> (a, a) -> f (a, b)
gtraverse = (a -> f b) -> (a, a) -> f (a, b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable [] where
  gtraverse :: (a -> f b) -> [a] -> f [b]
gtraverse = (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable (Arg a) where
  gtraverse :: (a -> f b) -> Arg a a -> f (Arg a b)
gtraverse = (a -> f b) -> Arg a a -> f (Arg a b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

#if MIN_VERSION_base(4,4,0)
instance GTraversable Complex where
  gtraverse :: (a -> f b) -> Complex a -> f (Complex b)
gtraverse = (a -> f b) -> Complex a -> f (Complex b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable (Const m) where
  gtraverse :: (a -> f b) -> Const m a -> f (Const m b)
gtraverse = (a -> f b) -> Const m a -> f (Const m b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable Down where
  gtraverse :: (a -> f b) -> Down a -> f (Down b)
gtraverse = (a -> f b) -> Down a -> f (Down b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable Dual where
  gtraverse :: (a -> f b) -> Dual a -> f (Dual b)
gtraverse = (a -> f b) -> Dual a -> f (Dual b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable (Either a) where
  gtraverse :: (a -> f b) -> Either a a -> f (Either a b)
gtraverse = (a -> f b) -> Either a a -> f (Either a b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable Monoid.First where
  gtraverse :: (a -> f b) -> First a -> f (First b)
gtraverse = (a -> f b) -> First a -> f (First b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable (Semigroup.First) where
  gtraverse :: (a -> f b) -> First a -> f (First b)
gtraverse = (a -> f b) -> First a -> f (First b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GTraversable Identity where
  gtraverse :: (a -> f b) -> Identity a -> f (Identity b)
gtraverse = (a -> f b) -> Identity a -> f (Identity b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable Monoid.Last where
  gtraverse :: (a -> f b) -> Last a -> f (Last b)
gtraverse = (a -> f b) -> Last a -> f (Last b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable Semigroup.Last where
  gtraverse :: (a -> f b) -> Last a -> f (Last b)
gtraverse = (a -> f b) -> Last a -> f (Last b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable Max where
  gtraverse :: (a -> f b) -> Max a -> f (Max b)
gtraverse = (a -> f b) -> Max a -> f (Max b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable Maybe where
  gtraverse :: (a -> f b) -> Maybe a -> f (Maybe b)
gtraverse = (a -> f b) -> Maybe a -> f (Maybe b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable Min where
  gtraverse :: (a -> f b) -> Min a -> f (Min b)
gtraverse = (a -> f b) -> Min a -> f (Min b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable NonEmpty where
  gtraverse :: (a -> f b) -> NonEmpty a -> f (NonEmpty b)
gtraverse = (a -> f b) -> NonEmpty a -> f (NonEmpty b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable Monoid.Product where
  gtraverse :: (a -> f b) -> Product a -> f (Product b)
gtraverse = (a -> f b) -> Product a -> f (Product b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where
  gtraverse :: (a -> f b) -> Product f g a -> f (Product f g b)
gtraverse = (a -> f b) -> Product f g a -> f (Product f g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

#if MIN_VERSION_base(4,7,0)
instance GTraversable Proxy where
  gtraverse :: (a -> f b) -> Proxy a -> f (Proxy b)
gtraverse = (a -> f b) -> Proxy a -> f (Proxy b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable Monoid.Sum where
  gtraverse :: (a -> f b) -> Sum a -> f (Sum b)
gtraverse = (a -> f b) -> Sum a -> f (Sum b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where
  gtraverse :: (a -> f b) -> Sum f g a -> f (Sum f g b)
gtraverse = (a -> f b) -> Sum f g a -> f (Sum f g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault

instance GTraversable WrappedMonoid where
  gtraverse :: (a -> f b) -> WrappedMonoid a -> f (WrappedMonoid b)
gtraverse = (a -> f b) -> WrappedMonoid a -> f (WrappedMonoid b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault
#endif

instance GTraversable ZipList where
  gtraverse :: (a -> f b) -> ZipList a -> f (ZipList b)
gtraverse = (a -> f b) -> ZipList a -> f (ZipList b)
forall (t :: * -> *) (f :: * -> *) a b.
(Generic1 t, GTraversable' (Rep1 t), Applicative f) =>
(a -> f b) -> t a -> f (t b)
gtraversedefault