{-# Language DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,
             StandaloneDeriving, TypeFamilies, UndecidableInstances #-}

module Transformation.Shallow where

import Control.Applicative (Applicative, (<*>), liftA2)
import Data.Data (Data, Typeable)
import Data.Functor.Compose (Compose)
import Data.Functor.Const (Const)
import Data.Kind (Type)
import qualified Rank2
import qualified Data.Functor
import           Transformation (Transformation, Domain, Codomain)

import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)

-- | Like 'Rank2.Functor' except it takes a 'Transformation' instead of a polymorphic function
class (Transformation t, Rank2.Functor g) => Functor t g where
   (<$>) :: t -> g (Domain t) -> g (Codomain t)

-- | Like 'Rank2.Foldable' except it takes a 'Transformation' instead of a polymorphic function
class (Transformation t, Rank2.Foldable g) => Foldable t g where
   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> g (Domain t) -> m

-- | Like 'Rank2.Traversable' except it takes a 'Transformation' instead of a polymorphic function
class (Transformation t, Rank2.Traversable g) => Traversable t g where
   traverse :: Codomain t ~ Compose m f => t -> g (Domain t) -> m (g f)

instance (Functor t g, Functor t h) => Functor t (Rank2.Product g h) where
   t :: t
t <$> :: t -> Product g h (Domain t) -> Product g h (Codomain t)
<$> Rank2.Pair left :: g (Domain t)
left right :: h (Domain t)
right = g (Codomain t) -> h (Codomain t) -> Product g h (Codomain t)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Rank2.Pair (t
t t -> g (Domain t) -> g (Codomain t)
forall t (g :: (* -> *) -> *).
Functor t g =>
t -> g (Domain t) -> g (Codomain t)
<$> g (Domain t)
left) (t
t t -> h (Domain t) -> h (Codomain t)
forall t (g :: (* -> *) -> *).
Functor t g =>
t -> g (Domain t) -> g (Codomain t)
<$> h (Domain t)
right)

instance (Foldable t g, Foldable t h, Codomain t ~ Const m, Monoid m) => Foldable t (Rank2.Product g h) where
   foldMap :: t -> Product g h (Domain t) -> m
foldMap t :: t
t (Rank2.Pair left :: g (Domain t)
left right :: h (Domain t)
right) = t -> g (Domain t) -> m
forall t (g :: (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> g (Domain t) -> m
foldMap t
t g (Domain t)
left m -> m -> m
forall a. Semigroup a => a -> a -> a
<> t -> h (Domain t) -> m
forall t (g :: (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> g (Domain t) -> m
foldMap t
t h (Domain t)
right

instance (Traversable t g, Traversable t h, Codomain t ~ Compose m f, Applicative m) => Traversable t (Rank2.Product g h) where
   traverse :: t -> Product g h (Domain t) -> m (Product g h f)
traverse t :: t
t (Rank2.Pair left :: g (Domain t)
left right :: h (Domain t)
right) = (g f -> h f -> Product g h f)
-> m (g f) -> m (h f) -> m (Product g h f)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 g f -> h f -> Product g h f
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Rank2.Pair (t -> g (Domain t) -> m (g f)
forall t (g :: (* -> *) -> *) (m :: * -> *) (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) -> m (g f)
traverse t
t g (Domain t)
left) (t -> h (Domain t) -> m (h f)
forall t (g :: (* -> *) -> *) (m :: * -> *) (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> g (Domain t) -> m (g f)
traverse t
t h (Domain t)
right)

-- | Alphabetical synonym for '<$>'
fmap :: Functor t g => t -> g (Domain t) -> g (Codomain t)
fmap :: t -> g (Domain t) -> g (Codomain t)
fmap = t -> g (Domain t) -> g (Codomain t)
forall t (g :: (* -> *) -> *).
Functor t g =>
t -> g (Domain t) -> g (Codomain t)
(<$>)