{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

module Generics.Deriving.Copoint (
  -- * GCopoint class
    GCopoint(..)

  -- * Default method
  , gcopointdefault

  -- * Internal class
  , GCopoint'(..)

  ) where

import           Control.Applicative (WrappedMonad)

import           Data.Monoid (Dual)
import qualified Data.Monoid as Monoid (Sum)

import           Generics.Deriving.Base

#if MIN_VERSION_base(4,6,0)
import           Data.Ord (Down)
#else
import           GHC.Exts (Down)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic copoint
--------------------------------------------------------------------------------

-- General copoint may return 'Nothing'

class GCopoint' t where
    gcopoint' :: t a -> Maybe a

instance GCopoint' V1 where
    gcopoint' :: V1 a -> Maybe a
gcopoint' V1 a
_ = Maybe a
forall a. Maybe a
Nothing

instance GCopoint' U1 where
    gcopoint' :: U1 a -> Maybe a
gcopoint' U1 a
U1 = Maybe a
forall a. Maybe a
Nothing

instance GCopoint' Par1 where
    gcopoint' :: Par1 a -> Maybe a
gcopoint' (Par1 a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

instance GCopoint' (K1 i c) where
    gcopoint' :: K1 i c a -> Maybe a
gcopoint' K1 i c a
_ = Maybe a
forall a. Maybe a
Nothing

instance GCopoint' f => GCopoint' (M1 i c f) where
    gcopoint' :: M1 i c f a -> Maybe a
gcopoint' (M1 f a
a) = f a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' f a
a

instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where
    gcopoint' :: (:+:) f g a -> Maybe a
gcopoint' (L1 f a
a) = f a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' f a
a
    gcopoint' (R1 g a
a) = g a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' g a
a

-- Favours left "hole" for copoint
instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where
    gcopoint' :: (:*:) f g a -> Maybe a
gcopoint' (f a
a :*: g a
b) = case (f a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' f a
a) of
                            Just a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                            Maybe a
Nothing -> g a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' g a
b

instance (GCopoint f) => GCopoint' (Rec1 f) where
    gcopoint' :: Rec1 f a -> Maybe a
gcopoint' (Rec1 f a
a) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ f a -> a
forall (d :: * -> *) a. GCopoint d => d a -> a
gcopoint f a
a

instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where
    gcopoint' :: (:.:) f g a -> Maybe a
gcopoint' (Comp1 f (g a)
x) = g a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' (g a -> Maybe a) -> (f (g a) -> g a) -> f (g a) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g a
forall (d :: * -> *) a. GCopoint d => d a -> a
gcopoint (f (g a) -> Maybe a) -> f (g a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ f (g a)
x

class GCopoint d where
  gcopoint :: d a -> a
#if __GLASGOW_HASKELL__ >= 701
  default gcopoint :: (Generic1 d, GCopoint' (Rep1 d))
                   => (d a -> a)
  gcopoint = d a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d))
                => d a -> a
gcopointdefault :: d a -> a
gcopointdefault d a
x = case (Rep1 d a -> Maybe a
forall (t :: * -> *) a. GCopoint' t => t a -> Maybe a
gcopoint' (Rep1 d a -> Maybe a) -> (d a -> Rep1 d a) -> d a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d a -> Rep1 d a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (d a -> Maybe a) -> d a -> Maybe a
forall a b. (a -> b) -> a -> b
$ d a
x) of
                      Just a
x' -> a
x'
                      Maybe a
Nothing -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Data type is not copointed"

-- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d

-- Base types instances
instance GCopoint ((,) a) where
  gcopoint :: (a, a) -> a
gcopoint = (a, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint ((,,) a b) where
  gcopoint :: (a, b, a) -> a
gcopoint = (a, b, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint ((,,,) a b c) where
  gcopoint :: (a, b, c, a) -> a
gcopoint = (a, b, c, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint ((,,,,) a b c d) where
  gcopoint :: (a, b, c, d, a) -> a
gcopoint = (a, b, c, d, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint ((,,,,,) a b c d e) where
  gcopoint :: (a, b, c, d, e, a) -> a
gcopoint = (a, b, c, d, e, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint ((,,,,,,) a b c d e f) where
  gcopoint :: (a, b, c, d, e, f, a) -> a
gcopoint = (a, b, c, d, e, f, a) -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

#if MIN_VERSION_base(4,8,0)
instance GCopoint f => GCopoint (Alt f) where
  gcopoint :: Alt f a -> a
gcopoint = Alt f a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

#if MIN_VERSION_base(4,9,0)
instance GCopoint (Arg a) where
  gcopoint :: Arg a a -> a
gcopoint = Arg a a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

instance GCopoint Down where
  gcopoint :: Down a -> a
gcopoint = Down a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint Dual where
  gcopoint :: Dual a -> a
gcopoint = Dual a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

#if MIN_VERSION_base(4,9,0)
instance GCopoint First where
  gcopoint :: First a -> a
gcopoint = First a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GCopoint Identity where
  gcopoint :: Identity a -> a
gcopoint = Identity a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

#if MIN_VERSION_base(4,9,0)
instance GCopoint Last where
  gcopoint :: Last a -> a
gcopoint = Last a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint Max where
  gcopoint :: Max a -> a
gcopoint = Max a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint Min where
  gcopoint :: Min a -> a
gcopoint = Min a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where
  gcopoint :: Sum f g a -> a
gcopoint = Sum f g a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif

instance GCopoint Monoid.Sum where
  gcopoint :: Sum a -> a
gcopoint = Sum a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

instance GCopoint m => GCopoint (WrappedMonad m) where
  gcopoint :: WrappedMonad m a -> a
gcopoint = WrappedMonad m a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault

#if MIN_VERSION_base(4,9,0)
instance GCopoint WrappedMonoid where
  gcopoint :: WrappedMonoid a -> a
gcopoint = WrappedMonoid a -> a
forall (d :: * -> *) a.
(Generic1 d, GCopoint' (Rep1 d)) =>
d a -> a
gcopointdefault
#endif