{-# LANGUAGE RankNTypes               #-}

module Data.Functor.Barbie.Layered
  ( FunctorB (..)
  ) where

import Barbies               (Unit (Unit), Void)
import Data.Data             (Proxy (Proxy))
import Data.Functor.Compose  (Compose (Compose))
import Data.Functor.Const    (Const (Const))
import Data.Functor.Constant (Constant (Constant))
import Data.Functor.Product  (Product (Pair))
import Data.Functor.Sum      (Sum (InL, InR))

-- | Barbie-types that can be mapped over. Instances of 'FunctorB' should
-- satisfy the following laws:
--
-- @
-- 'bmap' 'id' = 'id'
-- 'bmap' f . 'bmap' g = 'bmap' (f . g)
-- @
class FunctorB b where
  bmap :: forall f g. (Functor f, Functor g) => (forall a. f a -> g a) -> b f -> b g

instance FunctorB Proxy where
  bmap :: (forall a. f a -> g a) -> Proxy f -> Proxy g
bmap forall a. f a -> g a
_ Proxy f
_ = Proxy g
forall k (t :: k). Proxy t
Proxy

instance FunctorB Void where
  bmap :: (forall a. f a -> g a) -> Void f -> Void g
bmap forall a. f a -> g a
_ Void f
_ = Void g
forall a. HasCallStack => a
undefined

instance FunctorB Unit where
  bmap :: (forall a. f a -> g a) -> Unit f -> Unit g
bmap forall a. f a -> g a
_ Unit f
_ = Unit g
forall k (f :: k -> *). Unit f
Unit

instance FunctorB (Constant a) where
  bmap :: (forall a. f a -> g a) -> Constant a f -> Constant a g
bmap forall a. f a -> g a
_ (Constant a
a) = a -> Constant a g
forall k a (b :: k). a -> Constant a b
Constant a
a

instance FunctorB (Const a) where
  bmap :: (forall a. f a -> g a) -> Const a f -> Const a g
bmap forall a. f a -> g a
_ (Const a
a) = a -> Const a g
forall k a (b :: k). a -> Const a b
Const a
a

instance (FunctorB a, FunctorB b) => FunctorB (Product a b) where
  bmap :: (forall a. f a -> g a) -> Product a b f -> Product a b g
bmap forall a. f a -> g a
f (Pair a f
x b f
y) = a g -> b g -> Product a b g
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((forall a. f a -> g a) -> a f -> a g
forall (b :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
(FunctorB b, Functor f, Functor g) =>
(forall a. f a -> g a) -> b f -> b g
bmap forall a. f a -> g a
f a f
x) ((forall a. f a -> g a) -> b f -> b g
forall (b :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
(FunctorB b, Functor f, Functor g) =>
(forall a. f a -> g a) -> b f -> b g
bmap forall a. f a -> g a
f b f
y)

instance (FunctorB a, FunctorB b) => FunctorB (Sum a b) where
  bmap :: (forall a. f a -> g a) -> Sum a b f -> Sum a b g
bmap forall a. f a -> g a
f (InL a f
x) = a g -> Sum a b g
forall k (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL ((forall a. f a -> g a) -> a f -> a g
forall (b :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
(FunctorB b, Functor f, Functor g) =>
(forall a. f a -> g a) -> b f -> b g
bmap forall a. f a -> g a
f a f
x)
  bmap forall a. f a -> g a
f (InR b f
x) = b g -> Sum a b g
forall k (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR ((forall a. f a -> g a) -> b f -> b g
forall (b :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
(FunctorB b, Functor f, Functor g) =>
(forall a. f a -> g a) -> b f -> b g
bmap forall a. f a -> g a
f b f
x)

instance (Functor f, FunctorB b) => FunctorB (Compose f b) where
  bmap :: (forall a. f a -> g a) -> Compose f b f -> Compose f b g
bmap forall a. f a -> g a
h (Compose f (b f)
x) = f (b g) -> Compose f b g
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((forall a. f a -> g a) -> b f -> b g
forall (b :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
(FunctorB b, Functor f, Functor g) =>
(forall a. f a -> g a) -> b f -> b g
bmap forall a. f a -> g a
h (b f -> b g) -> f (b f) -> f (b g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b f)
x)