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

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 Data.Kind (Type)
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.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.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.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
   f :: forall a. p a -> q a
f <$> :: (forall a. p a -> q a) -> Product g1 g2 p p -> Product g1 g2 p q
<$> ~(Pair left :: p (g1 p p)
left right :: 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 g1 :: (~>) p q (g p p)
g1 h1 :: (~>) p q (h p p)
h1) <*> :: Product g h p (p ~> q) -> Product g h p p -> Product g h p q
<*> ~(Pair g2 :: p (g p p)
g2 h2 :: 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 f :: forall a. p a -> q a -> r a
f ~(Pair g1 :: p (g p p)
g1 h1 :: p (h p p)
h1) ~(Pair g2 :: q (g p p)
g2 h2 :: 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 f :: 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 f :: forall a. p a -> m
f ~(Pair g :: p (g p p)
g h :: 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 f :: forall a. p a -> m (q a)
f ~(Pair g :: p (g p p)
g h :: 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 w :: forall a. m (p a) -> q a
w f :: 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 <$> :: t
-> Product g h (Domain t) (Domain t)
-> Product g h (Codomain t) (Codomain t)
<$> Pair left :: Domain t (g (Domain t) (Domain t))
left right :: 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
t (Pair left :: Domain t (g (Domain t) (Domain t))
left right :: 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)
(<$>)