{-# LANGUAGE PolyKinds    #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Barbies.Internal.TraversableB
  ( TraversableB(..)
  , btraverse_
  , bsequence
  , bsequence'
  , bfoldMap

  , CanDeriveTraversableB
  , gbtraverseDefault
  )

where

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

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

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

  default btraverse
    :: ( Applicative e, CanDeriveTraversableB b f g)
    => (forall a . f a -> e (g a))
    -> b f
    -> e (b g)
  btraverse = forall {k} (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (e :: * -> *).
(Applicative e, CanDeriveTraversableB b f g) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
gbtraverseDefault



-- | Map each element to an action, evaluate these actions from left to right,
--   and ignore the results.
btraverse_
  :: (TraversableB b, Applicative e)
  => (forall a. f a -> e c)
  -> b f
  -> e ()
btraverse_ :: forall {k} (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *) c.
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e c) -> b f -> e ()
btraverse_ 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 (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse (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.
bsequence :: (Applicative e, TraversableB b) => b (Compose e f) -> e (b f)
bsequence :: forall {k} (e :: * -> *) (b :: (k -> *) -> *) (f :: k -> *).
(Applicative e, TraversableB b) =>
b (Compose e f) -> e (b f)
bsequence
  = forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

-- | A version of 'bsequence' with @f@ specialized to 'Identity'.
bsequence' :: (Applicative e, TraversableB b) => b e -> e (b Identity)
bsequence' :: forall (e :: * -> *) (b :: (* -> *) -> *).
(Applicative e, TraversableB b) =>
b e -> e (b Identity)
bsequence'
  = forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse (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.
bfoldMap :: (TraversableB b, Monoid m) => (forall a. f a -> m) -> b f -> m
bfoldMap :: forall {k} (b :: (k -> *) -> *) m (f :: k -> *).
(TraversableB b, Monoid m) =>
(forall (a :: k). f a -> m) -> b f -> m
bfoldMap 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} (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *) c.
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e c) -> b f -> e ()
btraverse_ (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)


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

-- | Default implementation of 'btraverse' based on 'Generic'.
gbtraverseDefault
  :: forall b f g e
  .  (Applicative e, CanDeriveTraversableB b f g)
  => (forall a . f a -> e (g a))
  -> b f -> e (b g)
gbtraverseDefault :: forall {k} (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (e :: * -> *).
(Applicative e, CanDeriveTraversableB b f g) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
gbtraverseDefault 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 @0)) 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 @0) 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 @0)
{-# INLINE gbtraverseDefault #-}


-- ------------------------------------------------------------
-- Generic derivation: Special cases for TraversableB
-- -----------------------------------------------------------

type P = Param

instance
  ( TraversableB b
  ) => GTraversable 0 f g (Rec (b (P 0 f)) (b f))
                          (Rec (b (P 0 g)) (b g))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 0
-> (forall (a :: k). f a -> t (g a))
-> Rec (b (P 0 f)) (b f) x
-> t (Rec (b (P 0 g)) (b g) x)
gtraverse Proxy 0
_ 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 (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse 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
   , TraversableB b
   ) => GTraversable 0 f g (Rec (h (b (P 0 f))) (h (b f)))
                           (Rec (h (b (P 0 g))) (h (b g)))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 0
-> (forall (a :: k). f a -> t (g a))
-> Rec (h (b (P 0 f))) (h (b f)) x
-> t (Rec (h (b (P 0 g))) (h (b g)) x)
gtraverse Proxy 0
_ 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 (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse 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
   , TraversableB b
   ) => GTraversable 0 f g (Rec (m (h (b (P 0 f)))) (m (h (b f))))
                           (Rec (m (h (b (P 0 g)))) (m (h (b g))))
  where
  gtraverse :: forall (t :: * -> *) (x :: k).
Applicative t =>
Proxy 0
-> (forall (a :: k). f a -> t (g a))
-> Rec (m (h (b (P 0 f)))) (m (h (b f))) x
-> t (Rec (m (h (b (P 0 g)))) (m (h (b g))) x)
gtraverse Proxy 0
_ 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 (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse 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 TraversableB Proxy where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a)) -> Proxy f -> e (Proxy g)
btraverse forall (a :: k). f a -> e (g a)
_ Proxy f
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (t :: k). Proxy t
Proxy
  {-# INLINE btraverse #-}

instance (TraversableB a, TraversableB b) => TraversableB (Product a b) where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a))
-> Product a b f -> e (Product a b g)
btraverse forall (a :: k). f a -> e (g a)
f (Pair a f
x b f
y) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
f a f
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
f b f
y
  {-# INLINE btraverse #-}

instance (TraversableB a, TraversableB b) => TraversableB (Sum a b) where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a)) -> Sum a b f -> e (Sum a b g)
btraverse forall (a :: k). f a -> e (g a)
f (InL a f
x) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
f a f
x
  btraverse forall (a :: k). f a -> e (g a)
f (InR b f
x) = 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 k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
f b f
x
  {-# INLINE btraverse #-}

instance TraversableB (Const a) where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a)) -> Const a f -> e (Const a g)
btraverse forall (a :: k). f a -> e (g a)
_ (Const a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} a (b :: k). a -> Const a b
Const a
x)
  {-# INLINE btraverse #-}

instance (Traversable f, TraversableB b) => TraversableB (f `Compose` b) where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a))
-> Compose f b f -> e (Compose f b g)
btraverse forall (a :: k). f a -> e (g a)
h (Compose f (b f)
x)
    = 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 k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
h) f (b f)
x
  {-# INLINE btraverse #-}

-- -----------------------------------------------------------
-- Instances for transformer types
-- -----------------------------------------------------------

instance TraversableB (Constant a) where
  btraverse :: forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative e =>
(forall (a :: k). f a -> e (g a))
-> Constant a f -> e (Constant a g)
btraverse forall (a :: k). f a -> e (g a)
_ (Constant a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} a (b :: k). a -> Constant a b
Constant a
x)
  {-# INLINE btraverse #-}