{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Profunctor.Product.Internal.Adaptor where
import Data.Profunctor (Profunctor, dimap, lmap)
import Data.Profunctor.Product (ProductProfunctor, (****), (***$))
import GHC.Generics (from, to,
M1(M1), K1(K1), (:*:)((:*:)),
Generic, Rep)
genericAdaptor :: GAdaptable p a b c => a -> p b c
genericAdaptor :: forall (p :: * -> * -> *) a b c. GAdaptable p a b c => a -> p b c
genericAdaptor a
a = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall a x. Generic a => a -> Rep a x
from forall a x. Generic a => Rep a x -> a
to (forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor (forall a x. Generic a => a -> Rep a x
from a
a))
type Adaptor p a = a -> p (Unzip 'Fst a) (Unzip 'Snd a)
type GAdaptable p a b c =
( Generic a, Generic b, Generic c
, GUnzip 'Fst (Rep a) ~ Rep b
, GUnzip 'Snd (Rep a) ~ Rep c
, GAdaptor p (Rep a)
)
data Select = Fst | Snd
class Unzippable (a :: k) where
type family Unzip (z :: Select) (a :: k) :: k where
Unzip z (f a) = Unzip' z f (Project z a)
Unzip z a = a
type family Unzip' (z :: Select) (a :: k) :: k where
Unzip' z a = Unzip z a
class TypePair a where
type Project (z :: Select) a
instance forall (p :: * -> * -> *) a b. TypePair (p a b) where
type Project 'Fst (p a b) = a
type Project 'Snd (p a b) = b
type family GUnzip (z :: Select) (f :: * -> *) :: * -> *
type instance GUnzip z (f :*: g) = GUnzip z f :*: GUnzip z g
type instance GUnzip z (K1 i c) = K1 i (Project z c)
type instance GUnzip z (M1 i c f) = M1 i c (GUnzip z f)
class Profunctor p => GAdaptor p f | f -> p where
gAdaptor :: f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
instance
(ProductProfunctor p, GAdaptor p f, GAdaptor p g)
=> GAdaptor p (f :*: g) where
gAdaptor :: forall a.
(:*:) f g a
-> p (GUnzip 'Fst (f :*: g) a) (GUnzip 'Snd (f :*: g) a)
gAdaptor (f a
f :*: g a
g) = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
***$ forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall {k} {f :: k -> *} {g :: k -> *} {p :: k}. (:*:) f g p -> f p
pfst (forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor f a
f)
forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall {k} {f :: k -> *} {g :: k -> *} {p :: k}. (:*:) f g p -> g p
psnd (forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor g a
g)
where pfst :: (:*:) f g p -> f p
pfst (f p
f' :*: g p
_) = f p
f'
psnd :: (:*:) f g p -> g p
psnd (f p
_ :*: g p
g') = g p
g'
instance GAdaptor p f => GAdaptor p (M1 i c f) where
gAdaptor :: forall a.
M1 i c f a
-> p (GUnzip 'Fst (M1 i c f) a) (GUnzip 'Snd (M1 i c f) a)
gAdaptor (M1 f a
f) = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap
(\(M1 GUnzip 'Fst f a
f') -> GUnzip 'Fst f a
f')
(\GUnzip 'Snd f a
f' -> forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 GUnzip 'Snd f a
f')
(forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor f a
f)
instance Profunctor p => GAdaptor p (K1 i (p a b)) where
gAdaptor :: forall a.
K1 i (p a b) a
-> p (GUnzip 'Fst (K1 i (p a b)) a) (GUnzip 'Snd (K1 i (p a b)) a)
gAdaptor (K1 p a b
c) = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap
(\(K1 a
c') -> a
c')
(\b
c' -> forall k i c (p :: k). c -> K1 i c p
K1 b
c')
p a b
c