{-# LANGUAGE PolyKinds    #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Barbies.Internal.TraversableT
  ( TraversableT(..)
  , ttraverse_
  , tsequence
  , tsequence'
  , tfoldMap

  , CanDeriveTraversableT
  , ttraverseDefault
  )

where

import Barbies.Generics.Traversable(GTraversable(..))
import Barbies.Internal.FunctorT(FunctorT (..))
import Barbies.Internal.Writer(execWr, tell)

import Control.Applicative.Backwards(Backwards (..))
import Control.Applicative.Lift(Lift(..))
import Control.Monad.Trans.Except(ExceptT(..))
import Control.Monad.Trans.Identity(IdentityT(..))
import Control.Monad.Trans.Maybe(MaybeT(..))
import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))

import Data.Functor           (void)
import Data.Functor.Compose   (Compose (..))
import Data.Functor.Const     (Const (..))
import Data.Functor.Identity  (Identity (..))
import Data.Functor.Product   (Product (..))
import Data.Functor.Reverse   (Reverse (..))
import Data.Functor.Sum       (Sum (..))
import Data.Kind              (Type)
import Data.Generics.GenericN
import Data.Proxy             (Proxy (..))

-- | Indexed-functors that can be traversed from left to right. Instances should
--   satisfy the following laws:
--
-- @
--  t . 'ttraverse' f   = 'ttraverse' (t . f)  -- naturality
-- 'ttraverse' 'Data.Functor.Identity' = 'Data.Functor.Identity'           -- identity
-- 'ttraverse' ('Compose' . 'fmap' g . f) = 'Compose' . 'fmap' ('ttraverse' g) . 'ttraverse' f -- composition
-- @
--
-- There is a default 'ttraverse' implementation for 'Generic' types, so
-- instances can derived automatically.
class FunctorT t => TraversableT (t :: (k -> Type) -> k' -> Type) where
  ttraverse
    :: Applicative e
    => (forall a . f a -> e (g a))
    -> t f x -> e (t g x)

  default ttraverse
    :: ( Applicative e, CanDeriveTraversableT t f g x)
    => (forall a . f a -> e (g a)) -> t f x -> e (t g x)
  ttraverse = forall {k} {k} (t :: (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *) (e :: * -> *) (x :: k).
(Applicative e, CanDeriveTraversableT t f g x) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverseDefault



-- | Map each element to an action, evaluate these actions from left to right,
--   and ignore the results.
ttraverse_
  :: (TraversableT t, Applicative e)
  => (forall a. f a -> e c)
  -> t f x -> e ()
ttraverse_ :: forall {k} {k'} (t :: (k -> *) -> k' -> *) (e :: * -> *)
       (f :: k -> *) c (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e c) -> t f x -> e ()
ttraverse_ forall (a :: k). f a -> e c
f
  = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: k). f a -> e c
f)


-- | Evaluate each action in the structure from left to right,
--   and collect the results.
tsequence
  :: (Applicative e, TraversableT t)
  => t (Compose e f) x
  -> e (t f x)
tsequence :: forall {k} {k'} (e :: * -> *) (t :: (k -> *) -> k' -> *)
       (f :: k -> *) (x :: k').
(Applicative e, TraversableT t) =>
t (Compose e f) x -> e (t f x)
tsequence
  = forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

-- | A version of 'tsequence' with @f@ specialized to 'Identity'.
tsequence'
  :: (Applicative e, TraversableT t)
  => t e x
  -> e (t Identity x)
tsequence' :: forall {k'} (e :: * -> *) (t :: (* -> *) -> k' -> *) (x :: k').
(Applicative e, TraversableT t) =>
t e x -> e (t Identity x)
tsequence'
  = forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)


-- | Map each element to a monoid, and combine the results.
tfoldMap
  :: ( TraversableT t, Monoid m)
  => (forall a. f a -> m)
  -> t f x
  -> m
tfoldMap :: forall {k} {k'} (t :: (k -> *) -> k' -> *) m (f :: k -> *)
       (x :: k').
(TraversableT t, Monoid m) =>
(forall (a :: k). f a -> m) -> t f x -> m
tfoldMap forall (a :: k). f a -> m
f
  = forall w a. Monoid w => Wr w a -> w
execWr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k'} (t :: (k -> *) -> k' -> *) (e :: * -> *)
       (f :: k -> *) c (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e c) -> t f x -> e ()
ttraverse_ (forall w. Monoid w => w -> Wr w ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: k). f a -> m
f)


-- | @'CanDeriveTraversableT' T f g x@ is in practice a predicate about @T@ only.
--   It is analogous to 'Barbies.Internal.FunctorT.CanDeriveFunctorT', so it
--   essentially requires the following to hold, for any arbitrary @f@:
--
--     * There is an instance of @'Generic' (T f x)@.
--
--     * @T f x@ can contain fields of type @t f x@ as long as there exists a
--       @'TraversableT' t@ instance. In particular, recursive usages of @T f x@
--       are allowed.
--
--     * @T f x@ can also contain usages of @t f x@ under a @'Traversable' h@.
--       For example, one could use @'Maybe' (T f x)@ when defining @T f x@.
type CanDeriveTraversableT t f g x
  = ( GenericP 1 (t f x)
    , GenericP 1 (t g x)
    , GTraversable 1 f g (RepP 1 (t f x)) (RepP 1 (t g x))
    )

-- | Default implementation of 'ttraverse' based on 'Generic'.
ttraverseDefault
  :: forall t f g e x
  .  (Applicative e, CanDeriveTraversableT t f g x)
  => (forall a . f a -> e (g a))
  -> t f x -> e (t g x)
ttraverseDefault :: forall {k} {k} (t :: (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *) (e :: * -> *) (x :: k).
(Applicative e, CanDeriveTraversableT t f g x) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverseDefault forall (a :: k). f a -> e (g a)
h
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (n :: Natural) a x.
GenericP n a =>
Proxy n -> RepP n a x -> a
toP (forall {k} (t :: k). Proxy t
Proxy @1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} {k} (n :: k) (f :: k -> *) (g :: k -> *)
       (repbf :: k -> *) (repbg :: k -> *) (t :: * -> *) (x :: k).
(GTraversable n f g repbf repbg, Applicative t) =>
Proxy n
-> (forall (a :: k). f a -> t (g a)) -> repbf x -> t (repbg x)
gtraverse (forall {k} (t :: k). Proxy t
Proxy @1) forall (a :: k). f a -> e (g a)
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Natural) a x.
GenericP n a =>
Proxy n -> a -> RepP n a x
fromP (forall {k} (t :: k). Proxy t
Proxy @1)
{-# INLINE ttraverseDefault #-}


-- ------------------------------------------------------------
-- Generic derivation: Special cases for TraversableT
-- -----------------------------------------------------------

type P = Param

instance
  ( TraversableT t
  ) => GTraversable 1 f g (Rec (t (P 1 f) x) (t f x))
                          (Rec (t (P 1 g) x) (t g x))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 1
-> (forall (a :: k). f a -> t (g a))
-> Rec (t (P 1 f) x) (t f x) x
-> t (Rec (t (P 1 g) x) (t g x) x)
gtraverse Proxy 1
_ forall (a :: k). f a -> t (g a)
h
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse forall (a :: k). f a -> t (g a)
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} p a (x :: k). Rec p a x -> K1 R a x
unRec
  {-# INLINE gtraverse #-}

instance
   ( Traversable h
   , TraversableT t
   ) => GTraversable 1 f g (Rec (h (t (P 1 f) x)) (h (t f x)))
                           (Rec (h (t (P 1 g) x)) (h (t g x)))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 1
-> (forall (a :: k). f a -> t (g a))
-> Rec (h (t (P 1 f) x)) (h (t f x)) x
-> t (Rec (h (t (P 1 g) x)) (h (t g x)) x)
gtraverse Proxy 1
_ forall (a :: k). f a -> t (g a)
h
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse forall (a :: k). f a -> t (g a)
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} p a (x :: k). Rec p a x -> K1 R a x
unRec
  {-# INLINE gtraverse #-}


-- This instance is the same as the previous instance but for nested
-- Traversables.
instance
   ( Traversable h
   , Traversable m
   , TraversableT t
   ) => GTraversable 1 f g (Rec (m (h (t (P 1 f) x))) (m (h (t f x))))
                           (Rec (m (h (t (P 1 g) x))) (m (h (t g x))))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 1
-> (forall (a :: k). f a -> t (g a))
-> Rec (m (h (t (P 1 f) x))) (m (h (t f x))) x
-> t (Rec (m (h (t (P 1 g) x))) (m (h (t g x))) x)
gtraverse Proxy 1
_ forall (a :: k). f a -> t (g a)
h
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} p a (x :: k). K1 R a x -> Rec p a x
Rec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall k k' (t :: (k -> *) -> k' -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *) (x :: k').
(TraversableT t, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> t f x -> e (t g x)
ttraverse forall (a :: k). f a -> t (g a)
h)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} p a (x :: k). Rec p a x -> K1 R a x
unRec
  {-# INLINE gtraverse #-}


-- -----------------------------------------------------------
-- Instances for base types
-- -----------------------------------------------------------

instance Traversable f => TraversableT (Compose f) where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a))
-> Compose f f x -> e (Compose f g x)
ttraverse forall (a :: k'). f a -> e (g a)
h (Compose f (f x)
fga)
    = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (a :: k'). f a -> e (g a)
h f (f x)
fga
  {-# INLINE ttraverse #-}

instance TraversableT (Product f) where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a))
-> Product f f x -> e (Product f g x)
ttraverse forall (a :: k'). f a -> e (g a)
h (Pair f x
fa f x
ga) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f x
fa forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: k'). f a -> e (g a)
h f x
ga
  {-# INLINE ttraverse #-}

instance TraversableT (Sum f) where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a)) -> Sum f f x -> e (Sum f g x)
ttraverse forall (a :: k'). f a -> e (g a)
h = \case
    InL f x
fa -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL f x
fa
    InR f x
ga -> forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: k'). f a -> e (g a)
h f x
ga
  {-# INLINE ttraverse #-}

-- -----------------------------------------------------------
-- Instances for transformers types
-- -----------------------------------------------------------

instance TraversableT Backwards where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a))
-> Backwards f x -> e (Backwards g x)
ttraverse forall (a :: k'). f a -> e (g a)
h (Backwards f x
fa)
    = forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: k'). f a -> e (g a)
h f x
fa
  {-# INLINE ttraverse #-}

instance TraversableT Lift where
  ttraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *) x.
Applicative e =>
(forall a. f a -> e (g a)) -> Lift f x -> e (Lift g x)
ttraverse forall a. f a -> e (g a)
h = \case
    Pure  x
a  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. a -> Lift f a
Pure x
a
    Other f x
fa -> forall (f :: * -> *) a. f a -> Lift f a
Other forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> e (g a)
h f x
fa
  {-# INLINE ttraverse #-}

instance TraversableT Reverse where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a))
-> Reverse f x -> e (Reverse g x)
ttraverse forall (a :: k'). f a -> e (g a)
h (Reverse f x
fa) = forall {k} (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: k'). f a -> e (g a)
h f x
fa
  {-# INLINE ttraverse #-}

instance TraversableT (ExceptT e) where
  ttraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *) x.
Applicative e =>
(forall a. f a -> e (g a)) -> ExceptT e f x -> e (ExceptT e g x)
ttraverse forall a. f a -> e (g a)
h (ExceptT f (Either e x)
mea)
    = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> e (g a)
h f (Either e x)
mea
  {-# INLINE ttraverse #-}

instance TraversableT IdentityT where
  ttraverse :: forall (e :: * -> *) (f :: k' -> *) (g :: k' -> *) (x :: k').
Applicative e =>
(forall (a :: k'). f a -> e (g a))
-> IdentityT f x -> e (IdentityT g x)
ttraverse forall (a :: k'). f a -> e (g a)
h (IdentityT f x
ma)
    = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: k'). f a -> e (g a)
h f x
ma
  {-# INLINE ttraverse #-}

instance TraversableT MaybeT where
  ttraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *) x.
Applicative e =>
(forall a. f a -> e (g a)) -> MaybeT f x -> e (MaybeT g x)
ttraverse forall a. f a -> e (g a)
h (MaybeT f (Maybe x)
mma)
    = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> e (g a)
h f (Maybe x)
mma
  {-# INLINE ttraverse #-}

instance TraversableT (Lazy.WriterT w) where
  ttraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *) x.
Applicative e =>
(forall a. f a -> e (g a)) -> WriterT w f x -> e (WriterT w g x)
ttraverse forall a. f a -> e (g a)
h (Lazy.WriterT f (x, w)
maw)
    = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> e (g a)
h f (x, w)
maw
  {-# INLINE ttraverse #-}

instance TraversableT (Strict.WriterT w) where
  ttraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *) x.
Applicative e =>
(forall a. f a -> e (g a)) -> WriterT w f x -> e (WriterT w g x)
ttraverse forall a. f a -> e (g a)
h (Strict.WriterT f (x, w)
maw)
    = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> e (g a)
h f (x, w)
maw
  {-# INLINE ttraverse #-}