{-# 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)

-- * Exported

-- | Generic adaptor.
--
-- @
-- 'genericAdaptor' :: 'ProductProfunctor' p =>
--                   'Adaptor' p (Foo (p a a') (p b b') (p c c'))
-- 'genericAdaptor' :: 'ProductProfunctor' p =>
--                   Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')
-- @
genericAdaptor :: GAdaptable p a b c => a -> p b c
genericAdaptor :: a -> p b c
genericAdaptor a
a = (b -> Rep b Any)
-> (Rep c Any -> c) -> p (Rep b Any) (Rep c Any) -> p b c
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap b -> Rep b Any
forall a x. Generic a => a -> Rep a x
from Rep c Any -> c
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> p (GUnzip 'Fst (Rep a) Any) (GUnzip 'Snd (Rep a) Any)
forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a))

-- | A type synonym to shorten the signature of an adaptor.
--
-- @
-- 'Adaptor' p (Foo (p a a') (p b b') (p c c'))
-- ~
-- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')
-- @
type Adaptor p a = a -> p (Unzip 'Fst a) (Unzip 'Snd a)

-- * Implementation

-- | A constraint synonym on generic types for which an adaptor can be
-- defined generically.
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)
  )

-- | A flag denoting a type-level field accessor.
data Select = Fst | Snd

-- | A type like
--
-- > T = Foo (p a a') (p b b') (p c c')
--
-- can be unzipped to
--
-- > Unzip 'Fst T = Foo a  b  c
-- > Unzip 'Snd T = Foo a' b' c'
--
-- This defines the type family 'Unzip' with versions of GHC older than 8.0.1.
-- For 8.0.1 and newer versions, 'Unzip' is an independent type family
-- and 'Unzippable' is just an empty class for backwards compatibility.
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

-- | A hack to enable kind-polymorphic recursion.
type family Unzip' (z :: Select) (a :: k) :: k where
  Unzip' z a = Unzip z a

-- There is a bug in GHC < 8 apparently preventing us from using pure
-- type families. https://ghc.haskell.org/trac/ghc/ticket/11699
-- Defining them as associated types seems to be a valid work around.

-- | A type @p a b@ can be seen as a type-level pair @'(a, b)@.
class TypePair a where
  -- | This type synonym extracts a component, @a@ or @b@,
  -- of that pair @p a b@.
  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

-- | Unzips the types of fields of a record.
--
-- >             T = (M1 _ _ (K1 _ (p c1 c2))) :*: (M1 _ _ (K1 _ (p d1 d2)))
-- > GUnzip 'Fst T = (M1 _ _ (K1 _    c1    )) :*: (M1 _ _ (K1 _    d1    ))
-- > GUnzip 'Snd T = (M1 _ _ (K1 _       c2 )) :*: (M1 _ _ (K1 _       d2 ))
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)

-- | Adaptors over generic representations of types.
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 a
-> p (GUnzip 'Fst (f :*: g) a) (GUnzip 'Snd (f :*: g) a)
gAdaptor (f a
f :*: g a
g) = GUnzip 'Snd f a
-> GUnzip 'Snd g a -> (:*:) (GUnzip 'Snd f) (GUnzip 'Snd g) a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
    (GUnzip 'Snd f a
 -> GUnzip 'Snd g a -> (:*:) (GUnzip 'Snd f) (GUnzip 'Snd g) a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a) (GUnzip 'Snd f a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a)
     (GUnzip 'Snd g a -> (:*:) (GUnzip 'Snd f) (GUnzip 'Snd g) a)
forall (p :: * -> * -> *) b c a.
ProductProfunctor p =>
(b -> c) -> p a b -> p a c
***$ ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a -> GUnzip 'Fst f a)
-> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a) (GUnzip 'Snd f a)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a -> GUnzip 'Fst f a
forall k (f :: k -> *) (g :: k -> *) (p :: k). (:*:) f g p -> f p
pfst (f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
forall (p :: * -> * -> *) (f :: * -> *) a.
GAdaptor p f =>
f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
gAdaptor f a
f)
    p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a)
  (GUnzip 'Snd g a -> (:*:) (GUnzip 'Snd f) (GUnzip 'Snd g) a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a) (GUnzip 'Snd g a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a)
     ((:*:) (GUnzip 'Snd f) (GUnzip 'Snd g) a)
forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
**** ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a -> GUnzip 'Fst g a)
-> p (GUnzip 'Fst g a) (GUnzip 'Snd g a)
-> p ((:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a) (GUnzip 'Snd g a)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (:*:) (GUnzip 'Fst f) (GUnzip 'Fst g) a -> GUnzip 'Fst g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). (:*:) f g p -> g p
psnd (g a -> p (GUnzip 'Fst g a) (GUnzip 'Snd g a)
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 :: 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) = (M1 i c (GUnzip 'Fst f) a -> GUnzip 'Fst f a)
-> (GUnzip 'Snd f a -> M1 i c (GUnzip 'Snd f) a)
-> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
-> p (M1 i c (GUnzip 'Fst f) a) (M1 i c (GUnzip 'Snd f) a)
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' -> GUnzip 'Snd f a -> M1 i c (GUnzip 'Snd f) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 GUnzip 'Snd f a
f')
    (f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)
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 :: 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) = (K1 i a a -> a)
-> (b -> K1 i b a) -> p a b -> p (K1 i a a) (K1 i b a)
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' -> b -> K1 i b a
forall k i c (p :: k). c -> K1 i c p
K1 b
c')
    p a b
c