-- | Generic implementation of 'Foldable' and 'Traversable'.
--
-- There is already a naive implementation using the generic @'Rep'@'s
-- own instances of 'Foldable' and 'Traversable'. However, deriving then
-- generates a lot of code that may not be simplified away by GHC,
-- that results in unnecessary run-time overhead.
--
-- In contrast, this implementation guarantees that the generated code is
-- identical to stock-derived instances of 'Foldable' and 'Traversable',
-- which have the following syntactic properties:
--
-- - constructors with zero fields use 'pure' once;
-- - constructors with one field use 'fmap' once;
-- - constructors with n >= 2 fields use 'liftA2' once and @('<*>')@ n-2 times.
--
-- The heavy lifting is actually done by the ap-normalize library.

{-# LANGUAGE
  DataKinds,
  EmptyCase,
  FlexibleContexts,
  FlexibleInstances,
  GADTs,
  KindSignatures,
  MultiParamTypeClasses,
  ScopedTypeVariables,
  TypeApplications,
  TypeOperators,
  UndecidableInstances,
  UndecidableSuperClasses #-}

module Generic.Data.Internal.Traversable where

import Control.Applicative (liftA2)
import Data.Kind (Type)
import Data.Monoid
import GHC.Generics

import ApNormalize

-- * Library

-- | Generic 'foldMap'.
--
-- @
-- instance 'Foldable' MyTypeF where
--   'foldMap' = 'gfoldMap'
-- @
gfoldMap :: (Generic1 f, GFoldable (Rep1 f), Monoid m) => (a -> m) -> f a -> m
gfoldMap :: (a -> m) -> f a -> m
gfoldMap = \a -> m
f -> EndoM m -> m
forall m. Monoid m => EndoM m -> m
lowerEndoM (EndoM m -> m) -> (f a -> EndoM m) -> f a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m) -> Rep1 f a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f (Rep1 f a -> EndoM m) -> (f a -> Rep1 f a) -> f a -> EndoM m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1
{-# INLINE gfoldMap #-}

-- | Generic 'traverse'.
--
-- @
-- instance 'Traversable' MyTypeF where
--   'traverse' = 'gtraverse'
-- @
gtraverse
  :: (Generic1 f, GTraversable (Rep1 f), Applicative m)
  => (a -> m b) -> f a -> m (f b)
gtraverse :: (a -> m b) -> f a -> m (f b)
gtraverse = \a -> m b
f -> Aps m (f b) -> m (f b)
forall (f :: * -> *) a. Applicative f => Aps f a -> f a
lowerAps (Aps m (f b) -> m (f b)) -> (f a -> Aps m (f b)) -> f a -> m (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep1 f b -> f b) -> Aps m (Rep1 f b) -> Aps m (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep1 f b -> f b
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Aps m (Rep1 f b) -> Aps m (f b))
-> (f a -> Aps m (Rep1 f b)) -> f a -> Aps m (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kleisli m a b -> Rep1 f a -> Aps m (Rep1 f b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ ((a -> m b) -> Kleisli m a b
forall (f :: * -> *) a b. (a -> f b) -> Kleisli f a b
Kleisli a -> m b
f) (Rep1 f a -> Aps m (Rep1 f b))
-> (f a -> Rep1 f a) -> f a -> Aps m (Rep1 f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1
{-# INLINE gtraverse #-}

-- | Generic 'sequenceA'.
--
-- @
-- instance 'Traversable' MyTypeF where
--   'sequenceA' = 'gsequenceA'
-- @
--
-- See also 'gtraverse'.
--
gsequenceA
  :: (Generic1 f, GTraversable (Rep1 f), Applicative m)
  => f (m a) -> m (f a)
gsequenceA :: f (m a) -> m (f a)
gsequenceA = Aps m (f a) -> m (f a)
forall (f :: * -> *) a. Applicative f => Aps f a -> f a
lowerAps (Aps m (f a) -> m (f a))
-> (f (m a) -> Aps m (f a)) -> f (m a) -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep1 f a -> f a) -> Aps m (Rep1 f a) -> Aps m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Aps m (Rep1 f a) -> Aps m (f a))
-> (f (m a) -> Aps m (Rep1 f a)) -> f (m a) -> Aps m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Equal m (m a) a -> Rep1 f (m a) -> Aps m (Rep1 f a)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ Equal m (m a) a
forall (f :: * -> *) b. Equal f (f b) b
Refl (Rep1 f (m a) -> Aps m (Rep1 f a))
-> (f (m a) -> Rep1 f (m a)) -> f (m a) -> Aps m (Rep1 f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (m a) -> Rep1 f (m a)
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1
{-# INLINE gsequenceA #-}

-- | Class of generic representations for which 'Foldable' can be derived.
class    GFoldable_ t => GFoldable t
instance GFoldable_ t => GFoldable t

-- | Class of generic representations for which 'Traversable' can be derived.
class    GTraversable_ t => GTraversable t
instance GTraversable_ t => GTraversable t

-- | Internal definition of 'GFoldable'.
class    (GFoldMap t, Foldable t) => GFoldable_ t
instance (GFoldMap t, Foldable t) => GFoldable_ t

-- | Internal definition of 'GTraversable'.
class    (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t
instance (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t

-- Implementation

-- ** Foldable

-- | Isomorphic to @Maybe m@, but we need to micromanage the
-- use of Monoid vs Semigroup to match exactly the output
-- of stock deriving, for inspection testing.
data Maybe' m = Nothing' | Just' m

type EndoM m = Endo (Maybe' m)

liftEndoM :: Monoid m => m -> EndoM m
liftEndoM :: m -> EndoM m
liftEndoM m
x = (Maybe' m -> Maybe' m) -> EndoM m
forall a. (a -> a) -> Endo a
Endo Maybe' m -> Maybe' m
app where
  app :: Maybe' m -> Maybe' m
app Maybe' m
Nothing' = m -> Maybe' m
forall m. m -> Maybe' m
Just' m
x
  app (Just' m
y) = m -> Maybe' m
forall m. m -> Maybe' m
Just' (m
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
y)
{-# INLINE liftEndoM #-}

lowerEndoM :: Monoid m => EndoM m -> m
lowerEndoM :: EndoM m -> m
lowerEndoM (Endo Maybe' m -> Maybe' m
app) = Maybe' m -> m
forall m. Monoid m => Maybe' m -> m
lowerMaybe (Maybe' m -> Maybe' m
app Maybe' m
forall m. Maybe' m
Nothing')
{-# INLINE lowerEndoM #-}

lowerMaybe :: Monoid m => Maybe' m -> m
lowerMaybe :: Maybe' m -> m
lowerMaybe Maybe' m
Nothing' = m
forall a. Monoid a => a
mempty
lowerMaybe (Just' m
x) = m
x
{-# INLINE lowerMaybe #-}

class GFoldMap t where
  gfoldMap_ :: Monoid m => (a -> m) -> t a -> EndoM m

instance GFoldMap f => GFoldMap (M1 i c f) where
  gfoldMap_ :: (a -> m) -> M1 i c f a -> EndoM m
gfoldMap_ a -> m
f (M1 f a
x) = (a -> m) -> f a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f f a
x
  {-# INLINE gfoldMap_ #-}

instance (GFoldMap f, GFoldMap g) => GFoldMap (f :+: g) where
  gfoldMap_ :: (a -> m) -> (:+:) f g a -> EndoM m
gfoldMap_ a -> m
f (L1 f a
x) = (a -> m) -> f a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f f a
x
  gfoldMap_ a -> m
f (R1 g a
y) = (a -> m) -> g a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f g a
y
  {-# INLINE gfoldMap_ #-}

instance (GFoldMap f, GFoldMap g) => GFoldMap (f :*: g) where
  gfoldMap_ :: (a -> m) -> (:*:) f g a -> EndoM m
gfoldMap_ a -> m
f (f a
x :*: g a
y) = (a -> m) -> f a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f f a
x EndoM m -> EndoM m -> EndoM m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> g a -> EndoM m
forall (t :: * -> *) m a.
(GFoldMap t, Monoid m) =>
(a -> m) -> t a -> EndoM m
gfoldMap_ a -> m
f g a
y
  {-# INLINE gfoldMap_ #-}

instance GFoldMap U1 where
  gfoldMap_ :: (a -> m) -> U1 a -> EndoM m
gfoldMap_ a -> m
_ U1 a
_ = EndoM m
forall a. Monoid a => a
mempty
  {-# INLINE gfoldMap_ #-}

instance GFoldMap V1 where
  gfoldMap_ :: (a -> m) -> V1 a -> EndoM m
gfoldMap_ a -> m
_ V1 a
v = case V1 a
v of {}
  {-# INLINE gfoldMap_ #-}

instance GFoldMap (K1 i a) where
  gfoldMap_ :: (a -> m) -> K1 i a a -> EndoM m
gfoldMap_ a -> m
_ (K1 a
_) = EndoM m
forall a. Monoid a => a
mempty
  {-# INLINE gfoldMap_ #-}

instance GFoldMap Par1 where
  gfoldMap_ :: (a -> m) -> Par1 a -> EndoM m
gfoldMap_ a -> m
f (Par1 a
x) = m -> EndoM m
forall m. Monoid m => m -> EndoM m
liftEndoM (a -> m
f a
x)
  {-# INLINE gfoldMap_ #-}

instance Foldable t => GFoldMap (Rec1 t) where
  gfoldMap_ :: (a -> m) -> Rec1 t a -> EndoM m
gfoldMap_ a -> m
f (Rec1 t a
x) = m -> EndoM m
forall m. Monoid m => m -> EndoM m
liftEndoM ((a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f t a
x)
  {-# INLINE gfoldMap_ #-}

instance (Foldable t, Foldable f) => GFoldMap (t :.: f) where
  gfoldMap_ :: (a -> m) -> (:.:) t f a -> EndoM m
gfoldMap_ a -> m
f (Comp1 t (f a)
x) = m -> EndoM m
forall m. Monoid m => m -> EndoM m
liftEndoM ((f a -> m) -> t (f a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) t (f a)
x)
  {-# INLINE gfoldMap_ #-}


-- ** Traversable

data Equal (f :: Type -> Type) a b where
  Refl :: Equal f (f b) b

newtype Kleisli f a b = Kleisli (a -> f b)

class GTraverse arr t where
  gtraverse_ :: Applicative f => arr f a b -> t a -> Aps f (t b)

instance GTraverse arr f => GTraverse arr (M1 i c f) where
  gtraverse_ :: arr f a b -> M1 i c f a -> Aps f (M1 i c f b)
gtraverse_ arr f a b
f (M1 f a
x) = 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) -> Aps f (f b) -> Aps f (M1 i c f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> arr f a b -> f a -> Aps f (f b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ arr f a b
f f a
x
  {-# INLINE gtraverse_ #-}

instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :+: g) where
  gtraverse_ :: arr f a b -> (:+:) f g a -> Aps f ((:+:) f g b)
gtraverse_ arr f a b
f (L1 f a
x) = f b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f b -> (:+:) f g b) -> Aps f (f b) -> Aps f ((:+:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> arr f a b -> f a -> Aps f (f b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ arr f a b
f f a
x
  gtraverse_ arr f a b
f (R1 g a
y) = g b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g b -> (:+:) f g b) -> Aps f (g b) -> Aps f ((:+:) f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> arr f a b -> g a -> Aps f (g b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ arr f a b
f g a
y
  {-# INLINE gtraverse_ #-}

instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :*: g) where
  gtraverse_ :: arr f a b -> (:*:) f g a -> Aps f ((:*:) f g b)
gtraverse_ arr f a b
f (f a
x :*: g a
y) = (f b -> g b -> (:*:) f g b)
-> Aps f (f b) -> Aps f (g b) -> Aps f ((:*:) f g b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f b -> g b -> (:*:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (arr f a b -> f a -> Aps f (f b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ arr f a b
f f a
x) (arr f a b -> g a -> Aps f (g b)
forall (arr :: (* -> *) -> * -> * -> *) (t :: * -> *) (f :: * -> *)
       a b.
(GTraverse arr t, Applicative f) =>
arr f a b -> t a -> Aps f (t b)
gtraverse_ arr f a b
f g a
y)
  {-# INLINE gtraverse_ #-}

instance GTraverse arr U1 where
  gtraverse_ :: arr f a b -> U1 a -> Aps f (U1 b)
gtraverse_ arr f a b
_ U1 a
_ = U1 b -> Aps f (U1 b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 b
forall k (p :: k). U1 p
U1
  {-# INLINE gtraverse_ #-}

instance GTraverse arr V1 where
  gtraverse_ :: arr f a b -> V1 a -> Aps f (V1 b)
gtraverse_ arr f a b
_ V1 a
v = case V1 a
v of {}
  {-# INLINE gtraverse_ #-}

instance GTraverse arr (K1 i a) where
  gtraverse_ :: arr f a b -> K1 i a a -> Aps f (K1 i a b)
gtraverse_ arr f a b
_ (K1 a
x) = K1 i a b -> Aps f (K1 i a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> K1 i a b
forall k i c (p :: k). c -> K1 i c p
K1 a
x)
  {-# INLINE gtraverse_ #-}

-- traverse

instance GTraverse Kleisli Par1 where
  gtraverse_ :: Kleisli f a b -> Par1 a -> Aps f (Par1 b)
gtraverse_ (Kleisli a -> f b
f) (Par1 a
x) = b -> Par1 b
forall p. p -> Par1 p
Par1 (b -> Par1 b) -> Aps f b -> Aps f (Par1 b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b -> Aps f b
forall (f :: * -> *) a. f a -> Aps f a
liftAps (a -> f b
f a
x)
  {-# INLINE gtraverse_ #-}

instance Traversable t => GTraverse Kleisli (Rec1 t) where
  gtraverse_ :: Kleisli f a b -> Rec1 t a -> Aps f (Rec1 t b)
gtraverse_ (Kleisli a -> f b
f) (Rec1 t a
x) = t b -> Rec1 t b
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (t b -> Rec1 t b) -> Aps f (t b) -> Aps f (Rec1 t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (t b) -> Aps f (t b)
forall (f :: * -> *) a. f a -> Aps f a
liftAps ((a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f t a
x)
  {-# INLINE gtraverse_ #-}

-- Oh no, the encoding with @(':.:')@ is quite broken.
--
-- @t1 (... (tn (t a)) ...)@ is represented as:
-- @(t1 :.: (... :.: (tn :.: Rec1 t) ...)) a@
-- but it would be more efficient to associate to the left:
-- @(((... (Rec1 t1 :.: t2) :.: ...) :.: tn) :.: t) a
instance (Traversable t, Traversable f) => GTraverse Kleisli (t :.: f) where
  gtraverse_ :: Kleisli f a b -> (:.:) t f a -> Aps f ((:.:) t f b)
gtraverse_ (Kleisli a -> f b
f) (Comp1 t (f a)
x) = t (f b) -> (:.:) t f b
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (t (f b) -> (:.:) t f b) -> Aps f (t (f b)) -> Aps f ((:.:) t f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (t (f b)) -> Aps f (t (f b))
forall (f :: * -> *) a. f a -> Aps f a
liftAps ((f a -> f (f b)) -> t (f a) -> f (t (f b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) t (f a)
x)
  {-# INLINE gtraverse_ #-}

-- sequenceA

instance GTraverse Equal Par1 where
  gtraverse_ :: Equal f a b -> Par1 a -> Aps f (Par1 b)
gtraverse_ Equal f a b
Refl (Par1 a
x) = b -> Par1 b
forall p. p -> Par1 p
Par1 (b -> Par1 b) -> Aps f b -> Aps f (Par1 b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b -> Aps f b
forall (f :: * -> *) a. f a -> Aps f a
liftAps a
f b
x
  {-# INLINE gtraverse_ #-}

instance Traversable t => GTraverse Equal (Rec1 t) where
  gtraverse_ :: Equal f a b -> Rec1 t a -> Aps f (Rec1 t b)
gtraverse_ Equal f a b
Refl (Rec1 t a
x) = t b -> Rec1 t b
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (t b -> Rec1 t b) -> Aps f (t b) -> Aps f (Rec1 t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (t b) -> Aps f (t b)
forall (f :: * -> *) a. f a -> Aps f a
liftAps (t (f b) -> f (t b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA t a
t (f b)
x)
  {-# INLINE gtraverse_ #-}

instance (Traversable t, Traversable f) => GTraverse Equal (t :.: f) where
  gtraverse_ :: Equal f a b -> (:.:) t f a -> Aps f ((:.:) t f b)
gtraverse_ Equal f a b
Refl (Comp1 t (f a)
x) = t (f b) -> (:.:) t f b
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (t (f b) -> (:.:) t f b) -> Aps f (t (f b)) -> Aps f ((:.:) t f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (t (f b)) -> Aps f (t (f b))
forall (f :: * -> *) a. f a -> Aps f a
liftAps ((f (f b) -> f (f b)) -> t (f (f b)) -> f (t (f b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse f (f b) -> f (f b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA t (f a)
t (f (f b))
x)
  {-# INLINE gtraverse_ #-}