{-# Language DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
TypeFamilies, TypeOperators, UndecidableInstances #-}
module Transformation where
import Data.Coerce (coerce)
import qualified Data.Functor.Compose as Functor
import Data.Functor.Const (Const)
import Data.Functor.Product (Product(Pair))
import Data.Functor.Sum (Sum(InL, InR))
import Data.Kind (Type)
import GHC.TypeLits (ErrorMessage (Text, ShowType, (:<>:)), TypeError)
import qualified Rank2
import Prelude hiding (($))
class Transformation t where
type Domain t :: Type -> Type
type Codomain t :: Type -> Type
class Transformation t => At t x where
($) :: t -> Domain t x -> Codomain t x
infixr 0 $
apply :: t `At` x => t -> Domain t x -> Codomain t x
apply :: forall t x. At t x => t -> Domain t x -> Codomain t x
apply = forall t x. At t x => t -> Domain t x -> Codomain t x
($)
data Compose t u = Compose t u
newtype Mapped (f :: Type -> Type) t = Mapped t
newtype Folded (f :: Type -> Type) t = Folded t
newtype Traversed (f :: Type -> Type) t = Traversed t
instance (Transformation t, Transformation u, Domain t ~ Codomain u) => Transformation (Compose t u) where
type Domain (Compose t u) = Domain u
type Codomain (Compose t u) = Codomain t
instance Transformation t => Transformation (Mapped f t) where
type Domain (Mapped f t) = Functor.Compose f (Domain t)
type Codomain (Mapped f t) = Functor.Compose f (Codomain t)
instance Transformation t => Transformation (Folded f t) where
type Domain (Folded f t) = Functor.Compose f (Domain t)
type Codomain (Folded f t) = Codomain t
instance (Transformation t, Codomain t ~ Functor.Compose m n) => Transformation (Traversed f t) where
type Domain (Traversed f t) = Functor.Compose f (Domain t)
type Codomain (Traversed f t) =
Functor.Compose (ComposeOuter (Codomain t)) (Functor.Compose f (ComposeInner (Codomain t)))
type family ComposeOuter (c :: Type -> Type) :: Type -> Type where
ComposeOuter (Functor.Compose p q) = p
type family ComposeInner (c :: Type -> Type) :: Type -> Type where
ComposeInner (Functor.Compose p q) = q
instance (t `At` x, u `At` x, Domain t ~ Codomain u) => Compose t u `At` x where
Compose t
t u
u $ :: Compose t u -> Domain (Compose t u) x -> Codomain (Compose t u) x
$ Domain (Compose t u) x
x = t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$ u
u forall t x. At t x => t -> Domain t x -> Codomain t x
$ Domain (Compose t u) x
x
instance (t `At` x, Functor f) => Mapped f t `At` x where
Mapped t
t $ :: Mapped f t -> Domain (Mapped f t) x -> Codomain (Mapped f t) x
$ Functor.Compose f (Domain t x)
x = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose ((t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Domain t x)
x)
instance (t `At` x, Foldable f, Codomain t ~ Const m, Monoid m) => Folded f t `At` x where
Folded t
t $ :: Folded f t -> Domain (Folded f t) x -> Codomain (Folded f t) x
$ Functor.Compose f (Domain t x)
x = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$) f (Domain t x)
x
instance (t `At` x, Traversable f, Codomain t ~ Functor.Compose m n, Applicative m) => Traversed f t `At` x where
Traversed t
t $ :: Traversed f t
-> Domain (Traversed f t) x -> Codomain (Traversed f t) x
$ Functor.Compose f (Domain t x)
x = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Functor.Compose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
Functor.getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$)) f (Domain t x)
x)
instance Transformation (Rank2.Arrow (p :: Type -> Type) q x) where
type Domain (Rank2.Arrow p q x) = p
type Codomain (Rank2.Arrow p q x) = q
instance Rank2.Arrow p q x `At` x where
$ :: Arrow p q x -> Domain (Arrow p q x) x -> Codomain (Arrow p q x) x
($) = forall {k} (p :: k -> *) (q :: k -> *) (a :: k).
Arrow p q a -> p a -> q a
Rank2.apply
instance (Transformation t1, Transformation t2, Domain t1 ~ Domain t2) => Transformation (t1, t2) where
type Domain (t1, t2) = Domain t1
type Codomain (t1, t2) = Product (Codomain t1) (Codomain t2)
instance (t `At` x, u `At` x, Domain t ~ Domain u) => (t, u) `At` x where
(t
t, u
u) $ :: (t, u) -> Domain (t, u) x -> Codomain (t, u) x
$ Domain (t, u) x
x = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$ Domain (t, u) x
x) (u
u forall t x. At t x => t -> Domain t x -> Codomain t x
$ Domain (t, u) x
x)
instance (Transformation t1, Transformation t2, Domain t1 ~ Domain t2) => Transformation (Either t1 t2) where
type Domain (Either t1 t2) = Domain t1
type Codomain (Either t1 t2) = Sum (Codomain t1) (Codomain t2)
instance (t `At` x, u `At` x, Domain t ~ Domain u) => Either t u `At` x where
Left t
t $ :: Either t u -> Domain (Either t u) x -> Codomain (Either t u) x
$ Domain (Either t u) x
x = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL (t
t forall t x. At t x => t -> Domain t x -> Codomain t x
$ Domain (Either t u) x
x)
Right u
t $ Domain (Either t u) x
x = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR (u
t forall t x. At t x => t -> Domain t x -> Codomain t x
$ Domain (Either t u) x
x)