{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 0
#endif

module Data.Copointed where

import Control.Applicative
import Data.Default.Class
import GHC.Generics

#ifdef MIN_VERSION_comonad
import Control.Comonad.Trans.Env
import Control.Comonad.Trans.Store
import Control.Comonad.Trans.Traced

#if !(MIN_VERSION_comonad(4,3,0))
import Data.Functor.Coproduct
#endif
#endif

#ifdef MIN_VERSION_containers
import Data.Tree
#endif

#ifdef MIN_VERSION_semigroupoids
import Data.Functor.Bind
#endif


#if defined(MIN_VERSION_semigroups) || (MIN_VERSION_base(4,9,0))
import Data.Semigroup as Semigroup
import Data.List.NonEmpty (NonEmpty(..))
#endif

import qualified Data.Monoid as Monoid

#ifdef MIN_VERSION_tagged
import Data.Tagged
#endif

#if defined(MIN_VERSION_transformers) || (MIN_VERSION_base(4,8,0))
import Data.Functor.Identity
#endif

#if defined(MIN_VERSION_transformers) || (MIN_VERSION_base(4,9,0))
import Data.Functor.Sum as F
import Data.Functor.Compose
#endif

#ifdef MIN_VERSION_transformers
import Data.Functor.Reverse
import Control.Applicative.Backwards
import Control.Applicative.Lift as Applicative
import Control.Monad.Trans.Identity
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
#endif

-- | 'Copointed' does not require a 'Functor', as the only relationship
-- between 'copoint' and 'fmap' is given by a free theorem.

class Copointed p where
  copoint :: p a -> a

instance Copointed ((,) a) where
  copoint :: forall a. (a, a) -> a
copoint = (a, a) -> a
forall a a. (a, a) -> a
snd

instance Copointed ((,,) a b) where
  copoint :: forall a. (a, b, a) -> a
copoint (a
_,b
_,a
a) = a
a

instance Copointed ((,,,) a b c) where
  copoint :: forall a. (a, b, c, a) -> a
copoint (a
_,b
_,c
_,a
a) = a
a

instance Default m => Copointed ((->)m) where
  copoint :: forall a. (m -> a) -> a
copoint m -> a
f = m -> a
f m
forall a. Default a => a
def

instance Copointed m => Copointed (WrappedMonad m) where
  copoint :: forall a. WrappedMonad m a -> a
copoint = m a -> a
forall a. m a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (m a -> a) -> (WrappedMonad m a -> m a) -> WrappedMonad m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedMonad m a -> m a
forall (m :: * -> *) a. WrappedMonad m a -> m a
unwrapMonad

#ifdef MIN_VERSION_comonad
instance (Default m, Copointed w) => Copointed (TracedT m w) where
  copoint :: forall a. TracedT m w a -> a
copoint (TracedT w (m -> a)
w) = w (m -> a) -> m -> a
forall a. w a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint w (m -> a)
w m
forall a. Default a => a
def

instance Copointed w => Copointed (EnvT e w) where
  copoint :: forall a. EnvT e w a -> a
copoint = w a -> a
forall a. w a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (w a -> a) -> (EnvT e w a -> w a) -> EnvT e w a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvT e w a -> w a
forall e (w :: * -> *) a. EnvT e w a -> w a
lowerEnvT

instance Copointed w => Copointed (StoreT s w) where
  copoint :: forall a. StoreT s w a -> a
copoint (StoreT w (s -> a)
wf s
s) = w (s -> a) -> s -> a
forall a. w a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint w (s -> a)
wf s
s
#endif

#ifdef MIN_VERSION_comonad
#if !(MIN_VERSION_comonad(4,3,0))
instance (Copointed p, Copointed q) => Copointed (Coproduct p q) where
  copoint = coproduct copoint copoint
#endif
#endif

#ifdef MIN_VERSION_containers
instance Copointed Tree where
  copoint :: forall a. Tree a -> a
copoint = Tree a -> a
forall a. Tree a -> a
rootLabel
#endif

#ifdef MIN_VERSION_tagged
instance Copointed (Tagged a) where
  copoint :: forall a. Tagged a a -> a
copoint = Tagged a a -> a
forall {k} (s :: k) b. Tagged s b -> b
unTagged
#endif

#if defined(MIN_VERSION_transformers) || (MIN_VERSION_base(4,8,0))
instance Copointed Identity where
  copoint :: forall a. Identity a -> a
copoint = Identity a -> a
forall a. Identity a -> a
runIdentity
#endif

#if defined(MIN_VERSION_transformers) || (MIN_VERSION_base(4,9,0))
instance (Copointed p, Copointed q) => Copointed (Compose p q) where
  copoint :: forall a. Compose p q a -> a
copoint = q a -> a
forall a. q a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (q a -> a) -> (Compose p q a -> q a) -> Compose p q a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (q a) -> q a
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (p (q a) -> q a)
-> (Compose p q a -> p (q a)) -> Compose p q a -> q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose p q a -> p (q a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

instance (Copointed f, Copointed g) => Copointed (F.Sum f g) where
  copoint :: forall a. Sum f g a -> a
copoint (F.InL f a
m) = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint f a
m
  copoint (F.InR g a
m) = g a -> a
forall a. g a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint g a
m
#endif

#ifdef MIN_VERSION_transformers
instance Copointed f => Copointed (Backwards f) where
  copoint :: forall a. Backwards f a -> a
copoint = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f a -> a) -> (Backwards f a -> f a) -> Backwards f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Backwards f a -> f a
forall {k} (f :: k -> *) (a :: k). Backwards f a -> f a
forwards

instance Copointed f => Copointed (Applicative.Lift f) where
  copoint :: forall a. Lift f a -> a
copoint (Pure a
a)   = a
a
  copoint (Other f a
fa) = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint f a
fa

instance Copointed f => Copointed (Reverse f) where
  copoint :: forall a. Reverse f a -> a
copoint = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f a -> a) -> (Reverse f a -> f a) -> Reverse f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reverse f a -> f a
forall {k} (f :: k -> *) (a :: k). Reverse f a -> f a
getReverse

instance Copointed m => Copointed (IdentityT m) where
  copoint :: forall a. IdentityT m a -> a
copoint = m a -> a
forall a. m a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (m a -> a) -> (IdentityT m a -> m a) -> IdentityT m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT m a -> m a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT

instance Copointed m => Copointed (Lazy.WriterT w m) where
  copoint :: forall a. WriterT w m a -> a
copoint = (a, w) -> a
forall a b. (a, b) -> a
fst ((a, w) -> a) -> (WriterT w m a -> (a, w)) -> WriterT w m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w) -> (a, w)
forall a. m a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (m (a, w) -> (a, w))
-> (WriterT w m a -> m (a, w)) -> WriterT w m a -> (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT

instance Copointed m => Copointed (Strict.WriterT w m) where
  copoint :: forall a. WriterT w m a -> a
copoint = (a, w) -> a
forall a b. (a, b) -> a
fst ((a, w) -> a) -> (WriterT w m a -> (a, w)) -> WriterT w m a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w) -> (a, w)
forall a. m a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (m (a, w) -> (a, w))
-> (WriterT w m a -> m (a, w)) -> WriterT w m a -> (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT
#endif

instance Copointed Monoid.Dual where
  copoint :: forall a. Dual a -> a
copoint = Dual a -> a
forall a. Dual a -> a
Monoid.getDual

instance Copointed Monoid.Sum where
  copoint :: forall a. Sum a -> a
copoint = Sum a -> a
forall a. Sum a -> a
Monoid.getSum

instance Copointed Monoid.Product where
  copoint :: forall a. Product a -> a
copoint = Product a -> a
forall a. Product a -> a
Monoid.getProduct

#if defined(MIN_VERSION_semigroups) || (MIN_VERSION_base(4,9,0))
instance Copointed NonEmpty where
  copoint :: forall a. NonEmpty a -> a
copoint ~(a
a :| [a]
_) = a
a

instance Copointed Semigroup.First where
  copoint :: forall a. First a -> a
copoint = First a -> a
forall a. First a -> a
Semigroup.getFirst

instance Copointed Semigroup.Last where
  copoint :: forall a. Last a -> a
copoint = Last a -> a
forall a. Last a -> a
Semigroup.getLast

instance Copointed Semigroup.Max where
  copoint :: forall a. Max a -> a
copoint = Max a -> a
forall a. Max a -> a
Semigroup.getMax

instance Copointed Semigroup.Min where
  copoint :: forall a. Min a -> a
copoint = Min a -> a
forall a. Min a -> a
Semigroup.getMin

instance Copointed WrappedMonoid where
  copoint :: forall a. WrappedMonoid a -> a
copoint = WrappedMonoid a -> a
forall a. WrappedMonoid a -> a
unwrapMonoid
#endif

#ifdef MIN_VERSION_semigroups
#if MIN_VERSION_semigroups(0,16,2)
#define HAVE_ARG 1
#endif
#elif MIN_VERSION_base(4,9,0)
#define HAVE_ARG 1
#endif

#ifdef HAVE_ARG
instance Copointed (Arg a) where
  copoint :: forall a. Arg a a -> a
copoint (Arg a
_ a
b) = a
b
#endif

#ifdef MIN_VERSION_semigroupoids
instance Copointed f => Copointed (WrappedApplicative f) where
  copoint :: forall a. WrappedApplicative f a -> a
copoint = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f a -> a)
-> (WrappedApplicative f a -> f a) -> WrappedApplicative f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedApplicative f a -> f a
forall (f :: * -> *) a. WrappedApplicative f a -> f a
unwrapApplicative

instance Copointed f => Copointed (MaybeApply f) where
  copoint :: forall a. MaybeApply f a -> a
copoint (MaybeApply (Left f a
fa)) = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint f a
fa
  copoint (MaybeApply (Right a
a)) = a
a
#endif

instance Copointed Par1 where
  copoint :: forall a. Par1 a -> a
copoint = Par1 a -> a
forall a. Par1 a -> a
unPar1

instance Copointed f => Copointed (M1 i c f) where
  copoint :: forall a. M1 i c f a -> a
copoint = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f a -> a) -> (M1 i c f a -> f a) -> M1 i c f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance Copointed f => Copointed (Rec1 f) where
  copoint :: forall a. Rec1 f a -> a
copoint = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f a -> a) -> (Rec1 f a -> f a) -> Rec1 f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec1 f a -> f a
forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1

instance (Copointed f, Copointed g) => Copointed (f :+: g) where
  copoint :: forall a. (:+:) f g a -> a
copoint (L1 f a
a) = f a -> a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint f a
a
  copoint (R1 g a
a) = g a -> a
forall a. g a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint g a
a

instance (Copointed f, Copointed g) => Copointed (f :.: g) where
  copoint :: forall a. (:.:) f g a -> a
copoint = g a -> a
forall a. g a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (g a -> a) -> ((:.:) f g a -> g a) -> (:.:) f g a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> g a
forall a. f a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint (f (g a) -> g a) -> ((:.:) f g a -> f (g a)) -> (:.:) f g a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) f g a -> f (g a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1