{-# Language DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,
             StandaloneDeriving, TypeFamilies, 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 Rank2
import qualified Data.Functor
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)

-- | 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 g1 g2 (p :: * -> *) (q :: * -> *) = Pair{Product g1 g2 p q -> q (g1 p p)
fst :: q (g1 p p),
                                                      Product g1 g2 p q -> q (g2 p p)
snd :: q (g2 p p)}

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

instance Rank2.Apply (Product g h p) where
   ~(Pair (~>) p q (g p p)
g1 (~>) p q (h p p)
h1) <*> :: 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) = q (g p p) -> q (h p p) -> Product g h p q
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair ((~>) p q (g p p) -> p (g p p) -> q (g p p)
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) ((~>) p q (h p p) -> p (h p p) -> q (h p p)
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 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) = r (g p p) -> r (h p p) -> Product g h p r
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair (p (g p p) -> q (g p p) -> r (g p p)
forall a. p a -> q a -> r a
f p (g p p)
g1 q (g p p)
g2) (p (h p p) -> q (h p p) -> r (h p p)
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 a. f a) -> Product g h p f
pure forall a. f a
f = f (g p p) -> f (h p p) -> Product g h p f
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair f (g p p)
forall a. f a
f f (h p p)
forall a. f a
f

instance Rank2.Foldable (Product g h p) where
   foldMap :: (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) = p (g p p) -> m
forall a. p a -> m
f p (g p p)
g m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` p (h p p) -> m
forall a. p a -> m
f p (h p p)
h

instance Rank2.Traversable (Product g h p) where
   traverse :: (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) = (q (g p p) -> q (h p p) -> Product g h p q)
-> m (q (g p p)) -> m (q (h p p)) -> m (Product g h p q)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 q (g p p) -> q (h p p) -> Product g h p q
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair (p (g p p) -> m (q (g p p))
forall a. p a -> m (q a)
f p (g p p)
g) (p (h p p) -> m (q (h p p))
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 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 :: forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair{fst :: q (g p p)
fst= m (p (g p p)) -> q (g p p)
forall a. m (p a) -> q a
w (Product g h p p -> p (g p p)
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
Product g1 g2 p q -> q (g1 p p)
fst (Product g h p p -> p (g p p))
-> m (Product g h p p) -> m (p (g p p))
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= m (p (h p p)) -> q (h p p)
forall a. m (p a) -> q a
w (Product g h p p -> p (h p p)
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
Product g1 g2 p q -> q (g2 p p)
snd (Product g h p p -> p (h p p))
-> m (Product g h p p) -> m (p (h p p))
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 = Codomain t (g (Codomain t) (Codomain t))
-> Codomain t (h (Codomain t) (Codomain t))
-> Product g h (Codomain t) (Codomain t)
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair (t
t t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain 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 t
-> Domain t (h (Domain t) (Domain t))
-> Codomain t (h (Codomain t) (Codomain 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 :: 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) = (f (g f f) -> f (h f f) -> Product g h f f)
-> m (f (g f f)) -> m (f (h f f)) -> m (Product g h f f)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (g f f) -> f (h f f) -> Product g h f f
forall (g1 :: (* -> *) -> (* -> *) -> *)
       (g2 :: (* -> *) -> (* -> *) -> *) (p :: * -> *) (q :: * -> *).
q (g1 p p) -> q (g2 p p) -> Product g1 g2 p q
Pair (t -> Domain t (g (Domain t) (Domain t)) -> m (f (g f f))
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) (t -> Domain t (h (Domain t) (Domain t)) -> m (f (h f f))
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)

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