{-# 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 a = dimap from to (gAdaptor (from 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 (f :*: g) = (:*:)
***$ lmap pfst (gAdaptor f)
**** lmap psnd (gAdaptor g)
where pfst (f' :*: _) = f'
psnd (_ :*: g') = g'
instance GAdaptor p f => GAdaptor p (M1 i c f) where
gAdaptor (M1 f) = dimap
(\(M1 f') -> f')
(\f' -> M1 f')
(gAdaptor f)
instance Profunctor p => GAdaptor p (K1 i (p a b)) where
gAdaptor (K1 c) = dimap
(\(K1 c') -> c')
(\c' -> K1 c')
c