{-# Language DeriveDataTypeable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes,
StandaloneDeriving, TypeFamilies, TypeOperators, 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 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)
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 <$>
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
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)
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)}
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)
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)
(<$>)
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