{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-- |
-- Module      :  Data.Functor.Contravariant.Compose
-- Copyright   :  (c) Edward Kmett 2010
-- License     :  BSD3
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Composition of contravariant functors.

module Data.Functor.Contravariant.Compose
  ( Compose(..)
  , ComposeFC(..)
  , ComposeCF(..)
  ) where

import Control.Arrow

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible

-- | Composition of two contravariant functors
newtype Compose f g a = Compose { forall (f :: * -> *) (g :: * -> *) a. Compose f g a -> f (g a)
getCompose :: f (g a) }

instance (Contravariant f, Contravariant g) => Functor (Compose f g) where
   fmap :: forall a b. (a -> b) -> Compose f g a -> Compose f g b
fmap a -> b
f (Compose f (g a)
x) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a -> b
f) f (g a)
x)

-- | Composition of covariant and contravariant functors
newtype ComposeFC f g a = ComposeFC { forall (f :: * -> *) (g :: * -> *) a. ComposeFC f g a -> f (g a)
getComposeFC :: f (g a) }

instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where
    contramap :: forall a' a. (a' -> a) -> ComposeFC f g a -> ComposeFC f g a'
contramap a' -> a
f (ComposeFC f (g a)
x) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f) f (g a)
x)

instance (Functor f, Functor g) => Functor (ComposeFC f g) where
    fmap :: forall a b. (a -> b) -> ComposeFC f g a -> ComposeFC f g b
fmap a -> b
f (ComposeFC f (g a)
x) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (g a)
x)

instance (Applicative f, Divisible g) => Divisible (ComposeFC f g) where
  conquer :: forall a. ComposeFC f g a
conquer = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Divisible f => f a
conquer
  divide :: forall a b c.
(a -> (b, c))
-> ComposeFC f g b -> ComposeFC f g c -> ComposeFC f g a
divide a -> (b, c)
abc (ComposeFC f (g b)
fb) (ComposeFC f (g c)
fc) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
abc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
fb forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
fc

instance (Applicative f, Decidable g) => Decidable (ComposeFC f g) where
  lose :: forall a. (a -> Void) -> ComposeFC f g a
lose a -> Void
f = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose a -> Void
f)
  choose :: forall a b c.
(a -> Either b c)
-> ComposeFC f g b -> ComposeFC f g c -> ComposeFC f g a
choose a -> Either b c
abc (ComposeFC f (g b)
fb) (ComposeFC f (g c)
fc) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
abc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
fb forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g c)
fc

-- | Composition of contravariant and covariant functors
newtype ComposeCF f g a = ComposeCF { forall (f :: * -> *) (g :: * -> *) a. ComposeCF f g a -> f (g a)
getComposeCF :: f (g a) }

instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where
    contramap :: forall a' a. (a' -> a) -> ComposeCF f g a -> ComposeCF f g a'
contramap a' -> a
f (ComposeCF f (g a)
x) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a' -> a
f) f (g a)
x)

instance (Functor f, Functor g) => Functor (ComposeCF f g) where
    fmap :: forall a b. (a -> b) -> ComposeCF f g a -> ComposeCF f g b
fmap a -> b
f (ComposeCF f (g a)
x) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (g a)
x)

instance (Divisible f, Applicative g) => Divisible (ComposeCF f g) where
  conquer :: forall a. ComposeCF f g a
conquer = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF forall (f :: * -> *) a. Divisible f => f a
conquer
  divide :: forall a b c.
(a -> (b, c))
-> ComposeCF f g b -> ComposeCF f g c -> ComposeCF f g a
divide a -> (b, c)
abc (ComposeCF f (g b)
fb) (ComposeCF f (g c)
fc) = forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (b, c)
abc) f (g b)
fb f (g c)
fc

funzip :: Functor f => f (a, b) -> (f a, f b)
funzip :: forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd