{-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, FlexibleContexts,
             FlexibleInstances, LambdaCase,
             MultiParamTypeClasses, TypeFamilies, TypeOperators #-}
module Data.Profunctor.Product.Default.Class where

import GHC.Exts (Constraint)
import GHC.Generics

import Data.Profunctor (Profunctor, dimap)
import Data.Profunctor.Product.Class

class Default p a b where
  -- Would rather call it "default", but that's a keyword
  def :: p a b
  default def :: (Profunctor p, Generic a, Generic b, GDefault p (Rep a) (Rep b)) => p a b
  def = p a b
forall (p :: * -> * -> *) a b.
(Profunctor p, Generic a, Generic b, GDefault p (Rep a) (Rep b)) =>
p a b
gdef

-- | See 'DefaultFields''. But this more general form allows the input and
-- output types to vary a bit.
type DefaultFields p a b = GDefCnstr p (Rep a) (Rep b)

-- | 'Default' constraints on the fields of a 'Generic' datatype.
--
-- For a type like
--
-- > data Foo = Bar { a :: Int, b :: String }
-- >          | Baz Bool
--
-- we get the following constraints
--
-- > DefaultFields' p Foo =
-- >   ( Default p Int Int
-- >   , Default p String String
-- >   , Default p Bool Bool
-- >   )
type DefaultFields' p a = DefaultFields p a a

-- | @'DefaultPConstraints' p a@ expands to the minimal combination of
-- @'Profunctor' p@, @'ProductProfunctor' p@, @'SumProfunctor' p@ needed to implement
-- the instance @'Default' p a a@ for a 'Generic' datatype @a@.
--
-- > DefaultPConstraints p Foo =
-- >   ( ProductProfunctor p      -- because Foo has a constructor Bar with many fields
-- >   , SumProfunctor p          -- because Foo has multiple constructors
-- >   )
--
-- > DefaultConstraints p (a, b) =
-- >   ( ProductProfunctor p      -- (a, b) has a single constructor with two fields
-- >   )
type DefaultPConstraints p a = GDefPCnstr p (Rep a)

-- | @'DefaultConstraints' p a b@ forms all of the context needed to implement
-- the instance @'Default' p a b@ for 'Generic' types @a@ and @b@.
--
-- This serves to abbreviate the context in instances of 'Default' for
-- parametric types.
type DefaultConstraints p a b = (DefaultPConstraints p a, DefaultFields p a b)

-- | This serves to abbreviate the context in instances of 'Default' for
-- non-parametric types.
type DefaultConstraints' p a = DefaultConstraints p a a

-- | A list of 'Default' constraints.
--
-- > Defaults '[p a a', p b b', p c c'] =
-- >   (Default p a a', Default p b b', Default p c c')
type family Defaults (as :: [*]) :: Constraint
type instance Defaults '[] = ()
type instance Defaults (p a a' ': as) = (Default p a a', Defaults as)

-- * Generic instance for Default

class GDefault p f g where
  type GDefCnstr p f g :: Constraint
  gdef1 :: p (f a) (g a)

instance ProductProfunctor p => GDefault p U1 U1 where
  type GDefCnstr p U1 U1 = ()
  gdef1 :: p (U1 a) (U1 a)
gdef1 = (U1 a -> ()) -> (() -> U1 a) -> p () () -> p (U1 a) (U1 a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (() -> U1 a -> ()
forall a b. a -> b -> a
const ()) (U1 a -> () -> U1 a
forall a b. a -> b -> a
const U1 a
forall k (p :: k). U1 p
U1) p () ()
forall (p :: * -> * -> *). ProductProfunctor p => p () ()
empty

instance (Profunctor p, GDefault p f g) => GDefault p (M1 i c f) (M1 i c g) where
  type GDefCnstr p (M1 i c f) (M1 i c g) = GDefCnstr p f g
  gdef1 :: p (M1 i c f a) (M1 i c g a)
gdef1 = (M1 i c f a -> f a)
-> (g a -> M1 i c g a)
-> p (f a) (g a)
-> p (M1 i c f a) (M1 i c g a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap M1 i c f a -> f a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 g a -> M1 i c g a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 p (f a) (g a)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1

instance (Profunctor p, Default p c c') => GDefault p (K1 i c) (K1 i c') where
  type GDefCnstr p (K1 i c) (K1 i c') = Default p c c'
  gdef1 :: p (K1 i c a) (K1 i c' a)
gdef1 = (K1 i c a -> c)
-> (c' -> K1 i c' a) -> p c c' -> p (K1 i c a) (K1 i c' a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap K1 i c a -> c
forall i c k (p :: k). K1 i c p -> c
unK1 c' -> K1 i c' a
forall k i c (p :: k). c -> K1 i c p
K1 p c c'
forall (p :: * -> * -> *) a b. Default p a b => p a b
def

instance (ProductProfunctor p, GDefault p f f', GDefault p g g') => GDefault p (f :*: g) (f' :*: g') where
  type GDefCnstr p (f :*: g) (f' :*: g') = (GDefCnstr p f f', GDefCnstr p g g')
  gdef1 :: p ((:*:) f g a) ((:*:) f' g' a)
gdef1 = ((:*:) f g a -> (f a, g a))
-> ((f' a, g' a) -> (:*:) f' g' a)
-> p (f a, g a) (f' a, g' a)
-> p ((:*:) f g a) ((:*:) f' g' a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\(f a
x :*: g a
y) -> (f a
x, g a
y)) ((f' a -> g' a -> (:*:) f' g' a) -> (f' a, g' a) -> (:*:) f' g' a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry f' a -> g' a -> (:*:) f' g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)) (p (f a, g a) (f' a, g' a) -> p ((:*:) f g a) ((:*:) f' g' a))
-> p (f a, g a) (f' a, g' a) -> p ((:*:) f g a) ((:*:) f' g' a)
forall a b. (a -> b) -> a -> b
$ p (f a) (f' a)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1 p (f a) (f' a) -> p (g a) (g' a) -> p (f a, g a) (f' a, g' a)
forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! p (g a) (g' a)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1

instance (SumProfunctor p, GDefault p f f', GDefault p g g') => GDefault p (f :+: g) (f' :+: g') where
  type GDefCnstr p (f :+: g) (f' :+: g') = (GDefCnstr p f f', GDefCnstr p g g')
  gdef1 :: p ((:+:) f g a) ((:+:) f' g' a)
gdef1 = ((:+:) f g a -> Either (f a) (g a))
-> (Either (f' a) (g' a) -> (:+:) f' g' a)
-> p (Either (f a) (g a)) (Either (f' a) (g' a))
-> p ((:+:) f g a) ((:+:) f' g' a)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (:+:) f g a -> Either (f a) (g a)
forall (f :: * -> *) (g :: * -> *) p.
(:+:) f g p -> Either (f p) (g p)
sumToEither Either (f' a) (g' a) -> (:+:) f' g' a
forall (f :: * -> *) p (g :: * -> *).
Either (f p) (g p) -> (:+:) f g p
eitherToSum (p (Either (f a) (g a)) (Either (f' a) (g' a))
 -> p ((:+:) f g a) ((:+:) f' g' a))
-> p (Either (f a) (g a)) (Either (f' a) (g' a))
-> p ((:+:) f g a) ((:+:) f' g' a)
forall a b. (a -> b) -> a -> b
$ p (f a) (f' a)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1 p (f a) (f' a)
-> p (g a) (g' a) -> p (Either (f a) (g a)) (Either (f' a) (g' a))
forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! p (g a) (g' a)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1
    where
      eitherToSum :: Either (f p) (g p) -> (:+:) f g p
eitherToSum = \case
        Left  f p
x -> f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f p
x
        Right g p
x -> g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g p
x
      sumToEither :: (:+:) f g p -> Either (f p) (g p)
sumToEither = \case
        L1 f p
x -> f p -> Either (f p) (g p)
forall a b. a -> Either a b
Left  f p
x
        R1 g p
x -> g p -> Either (f p) (g p)
forall a b. b -> Either a b
Right g p
x

type family GDefPCnstr (p :: * -> * -> *) (f :: * -> *) :: Constraint
type instance GDefPCnstr p U1 = ProductProfunctor p
type instance GDefPCnstr p (M1 i c f) = GDefPCnstr p f
type instance GDefPCnstr p (K1 i c) = Profunctor p
type instance GDefPCnstr p (f :*: g) = ProductProfunctor p
type instance GDefPCnstr p (f :+: g) = (SumProfunctor p, GDefPCnstr p f, GDefPCnstr p g)

gdef :: (Profunctor p, Generic a, Generic b, GDefault p (Rep a) (Rep b)) => p a b
gdef :: p a b
gdef = (a -> Rep a Any)
-> (Rep b Any -> b) -> p (Rep a Any) (Rep b Any) -> p a b
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to p (Rep a Any) (Rep b Any)
forall (p :: * -> * -> *) (f :: * -> *) (g :: * -> *) a.
GDefault p f g =>
p (f a) (g a)
gdef1