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

-- | Type classes 'Functor', 'Foldable', and 'Traversable' that correspond to the standard type classes of the same
-- name, but applying the given transformation to every descendant of the given tree node. The corresponding classes
-- in the "Transformation.Shallow" module operate only on the immediate children, while those from the
-- "Transformation.Full" module include the argument node itself.

module Transformation.Deep where

import Control.Applicative (Applicative, liftA2)
import Data.Data (Data, Typeable)
import Data.Functor.Compose (Compose)
import Data.Functor.Const (Const)
import qualified Data.Functor as Rank1
import qualified Data.Functor
import Data.Kind (Type)
import qualified Rank2
import           Transformation (Transformation, Domain, Codomain)
import qualified Transformation.Full as Full

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

-- | Like "Transformation.Shallow".'Transformation.Shallow.Functor' except it maps all descendants and not only immediate children
class (Transformation t, Rank2.Functor (g (Domain t))) => Functor t g where
   (<$>) :: t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
   infixl 4 <$>

-- | Like "Transformation.Shallow".'Transformation.Shallow.Foldable' except it folds all descendants and not only immediate children
class (Transformation t, Rank2.Foldable (g (Domain t))) => Foldable t g where
   foldMap :: (Codomain t ~ Const m, Monoid m) => t -> g (Domain t) (Domain t) -> m

-- | Like "Transformation.Shallow".'Transformation.Shallow.Traversable' except it folds all descendants and not only immediate children
class (Transformation t, Rank2.Traversable (g (Domain t))) => Traversable t g where
   traverse :: Codomain t ~ Compose m f => t -> g (Domain t) (Domain t) -> m (g f f)

-- | Like 'Data.Functor.Product.Product' for data types with two type constructor parameters
data Product g h (d :: Type -> Type) (s :: Type -> Type) =
   Pair{forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
Product g h d s -> s (g d d)
fst :: s (g d d),
        forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
Product g h d s -> s (h d d)
snd :: s (h d d)}

-- | Like 'Data.Functor.Sum.Sum' for data types with two type constructor parameters
data Sum g h (d :: Type -> Type) (s :: Type -> Type) =
   InL (s (g d d))
   | InR (s (h d d))

instance Rank2.Functor (Product g h p) where
   forall a. p a -> q a
f <$> :: forall (p :: * -> *) (q :: * -> *).
(forall a. p a -> q a) -> Product g h p p -> Product g h p q
<$> ~(Pair p (g p p)
left p (h p p)
right) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair (forall a. p a -> q a
f p (g p p)
left) (forall a. p a -> q a
f p (h p p)
right)

instance Rank2.Apply (Product g h p) where
   ~(Pair (~>) p q (g p p)
g1 (~>) p q (h p p)
h1) <*> :: forall (p :: * -> *) (q :: * -> *).
Product g h p (p ~> q) -> Product g h p p -> Product g h p q
<*> ~(Pair p (g p p)
g2 p (h p p)
h2) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair (forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply (~>) p q (g p p)
g1 p (g p p)
g2) (forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply (~>) p q (h p p)
h1 p (h p p)
h2)
   liftA2 :: forall (p :: * -> *) (q :: * -> *) (r :: * -> *).
(forall a. p a -> q a -> r a)
-> Product g h p p -> Product g h p q -> Product g h p r
liftA2 forall a. p a -> q a -> r a
f ~(Pair p (g p p)
g1 p (h p p)
h1) ~(Pair q (g p p)
g2 q (h p p)
h2) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair (forall a. p a -> q a -> r a
f p (g p p)
g1 q (g p p)
g2) (forall a. p a -> q a -> r a
f p (h p p)
h1 q (h p p)
h2)

instance Rank2.Applicative (Product g h p) where
   pure :: forall (f :: * -> *). (forall a. f a) -> Product g h p f
pure forall a. f a
f = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair forall a. f a
f forall a. f a
f

instance Rank2.Foldable (Product g h p) where
   foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall a. p a -> m) -> Product g h p p -> m
foldMap forall a. p a -> m
f ~(Pair p (g p p)
g p (h p p)
h) = forall a. p a -> m
f p (g p p)
g forall a. Monoid a => a -> a -> a
`mappend` forall a. p a -> m
f p (h p p)
h

instance Rank2.Traversable (Product g h p) where
   traverse :: forall (m :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative m =>
(forall a. p a -> m (q a))
-> Product g h p p -> m (Product g h p q)
traverse forall a. p a -> m (q a)
f ~(Pair p (g p p)
g p (h p p)
h) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair (forall a. p a -> m (q a)
f p (g p p)
g) (forall a. p a -> m (q a)
f p (h p p)
h)

instance Rank2.DistributiveTraversable (Product g h p)

instance Rank2.Distributive (Product g h p) where
   cotraverse :: forall (m :: * -> *) (p :: * -> *) (q :: * -> *).
Functor m =>
(forall a. m (p a) -> q a)
-> m (Product g h p p) -> Product g h p q
cotraverse forall a. m (p a) -> q a
w m (Product g h p p)
f = Pair{fst :: q (g p p)
fst= forall a. m (p a) -> q a
w (forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
Product g h d s -> s (g d d)
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Data.Functor.<$> m (Product g h p p)
f),
                         snd :: q (h p p)
snd= forall a. m (p a) -> q a
w (forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
Product g h d s -> s (h d d)
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Data.Functor.<$> m (Product g h p p)
f)}

instance (Full.Functor t g, Full.Functor t h) => Functor t (Product g h) where
   t
t <$> :: t
-> Product g h (Domain t) (Domain t)
-> Product g h (Codomain t) (Codomain t)
<$> Pair Domain t (g (Domain t) (Domain t))
left Domain t (h (Domain t) (Domain t))
right = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> s (h d d) -> Product g h d s
Pair (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.<$> Domain t (g (Domain t) (Domain t))
left) (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.<$> Domain t (h (Domain t) (Domain t))
right)

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

deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,
                   Data (q (g1 p p)), Data (q (g2 p p))) => Data (Product g1 g2 p q)
deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Product g1 g2 p q)

instance Rank2.Functor (Sum g h p) where
   forall a. p a -> q a
f <$> :: forall (p :: * -> *) (q :: * -> *).
(forall a. p a -> q a) -> Sum g h p p -> Sum g h p q
<$> InL p (g p p)
left = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> Sum g h d s
InL (forall a. p a -> q a
f p (g p p)
left)
   forall a. p a -> q a
f <$> InR p (h p p)
right = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (h d d) -> Sum g h d s
InR (forall a. p a -> q a
f p (h p p)
right)

instance Rank2.Foldable (Sum g h p) where
   foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall a. p a -> m) -> Sum g h p p -> m
foldMap forall a. p a -> m
f (InL p (g p p)
left) = forall a. p a -> m
f p (g p p)
left
   foldMap forall a. p a -> m
f (InR p (h p p)
right) = forall a. p a -> m
f p (h p p)
right

instance Rank2.Traversable (Sum g h p) where
   traverse :: forall (m :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative m =>
(forall a. p a -> m (q a)) -> Sum g h p p -> m (Sum g h p q)
traverse forall a. p a -> m (q a)
f (InL p (g p p)
left) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> Sum g h d s
InL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Rank1.<$> forall a. p a -> m (q a)
f p (g p p)
left
   traverse forall a. p a -> m (q a)
f (InR p (h p p)
right) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (h d d) -> Sum g h d s
InR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Rank1.<$> forall a. p a -> m (q a)
f p (h p p)
right

instance (Full.Functor t g, Full.Functor t h) => Functor t (Sum g h) where
   t
t <$> :: t
-> Sum g h (Domain t) (Domain t)
-> Sum g h (Codomain t) (Codomain t)
<$> InL Domain t (g (Domain t) (Domain t))
left = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> Sum g h d s
InL (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.<$> Domain t (g (Domain t) (Domain t))
left)
   t
t <$> InR Domain t (h (Domain t) (Domain t))
right = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (h d d) -> Sum g h d s
InR (t
t forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.<$> Domain t (h (Domain t) (Domain t))
right)

instance (Full.Foldable t g, Full.Foldable t h, Codomain t ~ Const m) => Foldable t (Sum g h) where
   foldMap :: forall m.
(Codomain t ~ Const m, Monoid m) =>
t -> Sum g h (Domain t) (Domain t) -> m
foldMap t
t (InL Domain t (g (Domain t) (Domain t))
left) = forall t (g :: (* -> *) -> (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> Domain t (g (Domain t) (Domain t)) -> m
Full.foldMap t
t Domain t (g (Domain t) (Domain t))
left
   foldMap t
t (InR Domain t (h (Domain t) (Domain t))
right) = forall t (g :: (* -> *) -> (* -> *) -> *) m.
(Foldable t g, Codomain t ~ Const m, Monoid m) =>
t -> Domain t (g (Domain t) (Domain t)) -> m
Full.foldMap t
t Domain t (h (Domain t) (Domain t))
right

instance (Full.Traversable t g, Full.Traversable t h, Codomain t ~ Compose m f, Applicative m) =>
         Traversable t (Sum g h) where
   traverse :: forall (m :: * -> *) (f :: * -> *).
(Codomain t ~ Compose m f) =>
t -> Sum g h (Domain t) (Domain t) -> m (Sum g h f f)
traverse t
t (InL Domain t (g (Domain t) (Domain t))
left) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (g d d) -> Sum g h d s
InL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Rank1.<$> forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
Full.traverse t
t Domain t (g (Domain t) (Domain t))
left
   traverse t
t (InR Domain t (h (Domain t) (Domain t))
right) = forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
s (h d d) -> Sum g h d s
InR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Rank1.<$> forall t (g :: (* -> *) -> (* -> *) -> *) (m :: * -> *)
       (f :: * -> *).
(Traversable t g, Codomain t ~ Compose m f) =>
t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
Full.traverse t
t Domain t (h (Domain t) (Domain t))
right

deriving instance (Typeable p, Typeable q, Typeable g1, Typeable g2,
                   Data (q (g1 p p)), Data (q (g2 p p))) => Data (Sum g1 g2 p q)
deriving instance (Show (q (g1 p p)), Show (q (g2 p p))) => Show (Sum g1 g2 p q)

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

-- | Equivalent of 'Data.Either.either'
eitherFromSum :: Sum g h d s -> Either (s (g d d)) (s (h d d))
eitherFromSum :: forall (g :: (* -> *) -> (* -> *) -> *)
       (h :: (* -> *) -> (* -> *) -> *) (d :: * -> *) (s :: * -> *).
Sum g h d s -> Either (s (g d d)) (s (h d d))
eitherFromSum (InL s (g d d)
left) = forall a b. a -> Either a b
Left s (g d d)
left
eitherFromSum (InR s (h d d)
right) = forall a b. b -> Either a b
Right s (h d d)
right