{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Trustworthy #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Compose
-- Copyright   :  (c) Ross Paterson 2010
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Composition of functors.
--
-- @since 4.9.0.0
-----------------------------------------------------------------------------

module Data.Functor.Compose (
    Compose(..),
  ) where

import Data.Functor.Classes

import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data)
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), readListDefault, readListPrecDefault)

infixr 9 `Compose`

-- | Right-to-left composition of functors.
-- The composition of applicative functors is always applicative,
-- but the composition of monads is not always a monad.
newtype Compose f g a = Compose { Compose f g a -> f (g a)
getCompose :: f (g a) }
  deriving ( Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- Instances of lifted Prelude classes

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
    liftEq :: (a -> b -> Bool) -> Compose f g a -> Compose f g b -> Bool
liftEq eq :: a -> b -> Bool
eq (Compose x :: f (g a)
x) (Compose y :: f (g b)
y) = (g a -> g b -> Bool) -> f (g a) -> f (g b) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq ((a -> b -> Bool) -> g a -> g b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq) f (g a)
x f (g b)
y

-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
    liftCompare :: (a -> b -> Ordering) -> Compose f g a -> Compose f g b -> Ordering
liftCompare comp :: a -> b -> Ordering
comp (Compose x :: f (g a)
x) (Compose y :: f (g b)
y) =
        (g a -> g b -> Ordering) -> f (g a) -> f (g b) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare ((a -> b -> Ordering) -> g a -> g b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
comp) f (g a)
x f (g b)
y

-- | @since 4.9.0.0
instance (Read1 f, Read1 g) => Read1 (Compose f g) where
    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Compose f g a)
liftReadPrec rp :: ReadPrec a
rp rl :: ReadPrec [a]
rl = ReadPrec (Compose f g a) -> ReadPrec (Compose f g a)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Compose f g a) -> ReadPrec (Compose f g a))
-> ReadPrec (Compose f g a) -> ReadPrec (Compose f g a)
forall a b. (a -> b) -> a -> b
$
        ReadPrec (f (g a))
-> String -> (f (g a) -> Compose f g a) -> ReadPrec (Compose f g a)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith (ReadPrec (g a) -> ReadPrec [g a] -> ReadPrec (f (g a))
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec (g a)
rp' ReadPrec [g a]
rl') "Compose" f (g a) -> Compose f g a
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose
      where
        rp' :: ReadPrec (g a)
rp' = ReadPrec a -> ReadPrec [a] -> ReadPrec (g a)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec     ReadPrec a
rp ReadPrec [a]
rl
        rl' :: ReadPrec [g a]
rl' = ReadPrec a -> ReadPrec [a] -> ReadPrec [g a]
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrec ReadPrec a
rp ReadPrec [a]
rl

    liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Compose f g a]
liftReadListPrec = ReadPrec a -> ReadPrec [a] -> ReadPrec [Compose f g a]
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrecDefault
    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Compose f g a]
liftReadList     = (Int -> ReadS a) -> ReadS [a] -> ReadS [Compose f g a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadListDefault

-- | @since 4.9.0.0
instance (Show1 f, Show1 g) => Show1 (Compose f g) where
    liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Compose f g a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (Compose x :: f (g a)
x) =
        (Int -> f (g a) -> ShowS) -> String -> Int -> f (g a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> g a -> ShowS)
-> ([g a] -> ShowS) -> Int -> f (g a) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> g a -> ShowS
sp' [g a] -> ShowS
sl') "Compose" Int
d f (g a)
x
      where
        sp' :: Int -> g a -> ShowS
sp' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> g a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl
        sl' :: [g a] -> ShowS
sl' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [g a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

-- Instances of Prelude classes

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
    == :: Compose f g a -> Compose f g a -> Bool
(==) = Compose f g a -> Compose f g a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
    compare :: Compose f g a -> Compose f g a -> Ordering
compare = Compose f g a -> Compose f g a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

-- | @since 4.9.0.0
instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
    readPrec :: ReadPrec (Compose f g a)
readPrec = ReadPrec (Compose f g a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1

    readListPrec :: ReadPrec [Compose f g a]
readListPrec = ReadPrec [Compose f g a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Compose f g a]
readList     = ReadS [Compose f g a]
forall a. Read a => ReadS [a]
readListDefault

-- | @since 4.9.0.0
instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
    showsPrec :: Int -> Compose f g a -> ShowS
showsPrec = Int -> Compose f g a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

-- Functor instances

-- | @since 4.9.0.0
instance (Functor f, Functor g) => Functor (Compose f g) where
    fmap :: (a -> b) -> Compose f g a -> Compose f g b
fmap f :: a -> b
f (Compose x :: f (g a)
x) = f (g b) -> Compose f g b
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose ((g a -> g b) -> f (g a) -> f (g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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)

-- | @since 4.9.0.0
instance (Foldable f, Foldable g) => Foldable (Compose f g) where
    foldMap :: (a -> m) -> Compose f g a -> m
foldMap f :: a -> m
f (Compose t :: f (g a)
t) = (g a -> m) -> f (g a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> g a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) f (g a)
t

-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Compose f g) where
    traverse :: (a -> f b) -> Compose f g a -> f (Compose f g b)
traverse f :: a -> f b
f (Compose t :: f (g a)
t) = f (g b) -> Compose f g b
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose (f (g b) -> Compose f g b) -> f (f (g b)) -> f (Compose f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g a -> f (g b)) -> f (g a) -> f (f (g b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) f (g a)
t

-- | @since 4.9.0.0
instance (Applicative f, Applicative g) => Applicative (Compose f g) where
    pure :: a -> Compose f g a
pure x :: a
x = f (g a) -> Compose f g a
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose (g a -> f (g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
    Compose f :: f (g (a -> b))
f <*> :: Compose f g (a -> b) -> Compose f g a -> Compose f g b
<*> Compose x :: f (g a)
x = f (g b) -> Compose f g b
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose ((g (a -> b) -> g a -> g b) -> f (g (a -> b)) -> f (g a) -> f (g b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) f (g (a -> b))
f f (g a)
x)
    liftA2 :: (a -> b -> c) -> Compose f g a -> Compose f g b -> Compose f g c
liftA2 f :: a -> b -> c
f (Compose x :: f (g a)
x) (Compose y :: f (g b)
y) =
      f (g c) -> Compose f g c
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose ((g a -> g b -> g c) -> f (g a) -> f (g b) -> f (g c)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> b -> c) -> g a -> g b -> g c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f) f (g a)
x f (g b)
y)

-- | @since 4.9.0.0
instance (Alternative f, Applicative g) => Alternative (Compose f g) where
    empty :: Compose f g a
empty = f (g a) -> Compose f g a
forall k k (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose f (g a)
forall (f :: * -> *) a. Alternative f => f a
empty
    <|> :: Compose f g a -> Compose f g a -> Compose f g a
(<|>) = (f (g a) -> f (g a) -> f (g a))
-> Compose f g a -> Compose f g a -> Compose f g a
forall a b. Coercible a b => a -> b
coerce (f (g a) -> f (g a) -> f (g a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) :: f (g a) -> f (g a) -> f (g a))
      :: forall a . Compose f g a -> Compose f g a -> Compose f g a