{-# 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) = f (g b) -> Compose f g b
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> Compose f g a
Compose ((g b -> g a) -> f (g a) -> f (g b)
forall a' a. (a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((a -> b) -> g b -> g a
forall a' a. (a' -> a) -> g a -> g a'
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) = f (g a') -> ComposeFC f g a'
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC ((g a -> g a') -> f (g a) -> f (g a')
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a' -> a) -> g a -> g a'
forall a' a. (a' -> a) -> g a -> g a'
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) = f (g b) -> ComposeFC f g b
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC ((g a -> g b) -> f (g a) -> f (g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> g a -> g b
forall a b. (a -> b) -> g a -> g b
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 = f (g a) -> ComposeFC f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (f (g a) -> ComposeFC f g a) -> f (g a) -> ComposeFC f g a
forall a b. (a -> b) -> a -> b
$ g a -> f (g a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure g a
forall a. g a
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) = f (g a) -> ComposeFC f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (f (g a) -> ComposeFC f g a) -> f (g a) -> ComposeFC f g a
forall a b. (a -> b) -> a -> b
$ (a -> (b, c)) -> g b -> g c -> g a
forall a b c. (a -> (b, c)) -> g b -> g c -> g a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
abc (g b -> g c -> g a) -> f (g b) -> f (g c -> g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
fb f (g c -> g a) -> f (g c) -> f (g a)
forall a b. f (a -> b) -> f a -> f b
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 = f (g a) -> ComposeFC f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (f (g a) -> ComposeFC f g a) -> f (g a) -> ComposeFC f g a
forall a b. (a -> b) -> a -> b
$ g a -> f (g a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> Void) -> g a
forall a. (a -> Void) -> g a
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) = f (g a) -> ComposeFC f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeFC f g a
ComposeFC (f (g a) -> ComposeFC f g a) -> f (g a) -> ComposeFC f g a
forall a b. (a -> b) -> a -> b
$ (a -> Either b c) -> g b -> g c -> g a
forall a b c. (a -> Either b c) -> g b -> g c -> g a
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
abc (g b -> g c -> g a) -> f (g b) -> f (g c -> g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g b)
fb f (g c -> g a) -> f (g c) -> f (g a)
forall a b. f (a -> b) -> f a -> f b
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) = f (g a') -> ComposeCF f g a'
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF ((g a' -> g a) -> f (g a) -> f (g a')
forall a' a. (a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((a' -> a) -> g a' -> g a
forall a b. (a -> b) -> g a -> g b
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) = f (g b) -> ComposeCF f g b
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF ((g a -> g b) -> f (g a) -> f (g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> g a -> g b
forall a b. (a -> b) -> g a -> g b
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 = f (g a) -> ComposeCF f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF f (g a)
forall a. f a
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) = f (g a) -> ComposeCF f g a
forall (f :: * -> *) (g :: * -> *) a. f (g a) -> ComposeCF f g a
ComposeCF (f (g a) -> ComposeCF f g a) -> f (g a) -> ComposeCF f g a
forall a b. (a -> b) -> a -> b
$ (g a -> (g b, g c)) -> f (g b) -> f (g c) -> f (g a)
forall a b c. (a -> (b, c)) -> f b -> f c -> f a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (g (b, c) -> (g b, g c)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
funzip (g (b, c) -> (g b, g c)) -> (g a -> g (b, c)) -> g a -> (g b, g c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (b, c)) -> g a -> g (b, c)
forall a b. (a -> b) -> g a -> g b
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 = ((a, b) -> a) -> f (a, b) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst (f (a, b) -> f a) -> (f (a, b) -> f b) -> f (a, b) -> (f a, f b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((a, b) -> b) -> f (a, b) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd