{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Product
-- Copyright   :  (c) Ross Paterson 2010
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Products, lifted to functors.
--
-- @since 4.9.0.0
-----------------------------------------------------------------------------

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

import Control.Applicative
import Control.Monad (MonadPlus(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.Zip (MonadZip(mzipWith))
import Data.Data (Data)
import Data.Functor.Classes
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), readListDefault, readListPrecDefault)

-- | Lifted product of functors.
data Product f g a = Pair (f a) (g a)
  deriving ( Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
    liftEq :: (a -> b -> Bool) -> Product f g a -> Product f g b -> Bool
liftEq eq :: a -> b -> Bool
eq (Pair x1 :: f a
x1 y1 :: g a
y1) (Pair x2 :: f b
x2 y2 :: g b
y2) = (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
x1 f b
x2 Bool -> Bool -> Bool
&& (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 g a
y1 g b
y2

-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
    liftCompare :: (a -> b -> Ordering) -> Product f g a -> Product f g b -> Ordering
liftCompare comp :: a -> b -> Ordering
comp (Pair x1 :: f a
x1 y1 :: g a
y1) (Pair x2 :: f b
x2 y2 :: g b
y2) =
        (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
comp f a
x1 f b
x2 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` (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 g a
y1 g b
y2

-- | @since 4.9.0.0
instance (Read1 f, Read1 g) => Read1 (Product f g) where
    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Product f g a)
liftReadPrec rp :: ReadPrec a
rp rl :: ReadPrec [a]
rl = ReadPrec (Product f g a) -> ReadPrec (Product f g a)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Product f g a) -> ReadPrec (Product f g a))
-> ReadPrec (Product f g a) -> ReadPrec (Product f g a)
forall a b. (a -> b) -> a -> b
$
        ReadPrec (f a)
-> ReadPrec (g a)
-> String
-> (f a -> g a -> Product f g a)
-> ReadPrec (Product f g a)
forall a b t.
ReadPrec a -> ReadPrec b -> String -> (a -> b -> t) -> ReadPrec t
readBinaryWith (ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
rl) (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) "Pair" f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair

    liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a]
liftReadListPrec = ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a]
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrecDefault
    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Product f g a]
liftReadList     = (Int -> ReadS a) -> ReadS [a] -> ReadS [Product 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 (Product f g) where
    liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Product f g a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (Pair x :: f a
x y :: g a
y) =
        (Int -> f a -> ShowS)
-> (Int -> g a -> ShowS) -> String -> Int -> f a -> g a -> ShowS
forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) ((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) "Pair" Int
d f a
x g a
y

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
    where == :: Product f g a -> Product f g a -> Bool
(==) = Product f g a -> Product 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 (Product f g a) where
    compare :: Product f g a -> Product f g a -> Ordering
compare = Product f g a -> Product 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 (Product f g a) where
    readPrec :: ReadPrec (Product f g a)
readPrec = ReadPrec (Product f g a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1

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

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

-- | @since 4.9.0.0
instance (Functor f, Functor g) => Functor (Product f g) where
    fmap :: (a -> b) -> Product f g a -> Product f g b
fmap f :: a -> b
f (Pair x :: f a
x y :: g a
y) = f b -> g b -> Product f g b
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x) ((a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f g a
y)

-- | @since 4.9.0.0
instance (Foldable f, Foldable g) => Foldable (Product f g) where
    foldMap :: (a -> m) -> Product f g a -> m
foldMap f :: a -> m
f (Pair x :: f a
x y :: g a
y) = (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> g a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f g a
y

-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Product f g) where
    traverse :: (a -> f b) -> Product f g a -> f (Product f g b)
traverse f :: a -> f b
f (Pair x :: f a
x y :: g a
y) = (f b -> g b -> Product f g b)
-> f (f b) -> f (g b) -> f (Product f g b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f b -> g b -> Product f g b
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f f a
x) ((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 g a
y)

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

-- | @since 4.9.0.0
instance (Alternative f, Alternative g) => Alternative (Product f g) where
    empty :: Product f g a
empty = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
forall (f :: * -> *) a. Alternative f => f a
empty g a
forall (f :: * -> *) a. Alternative f => f a
empty
    Pair x1 :: f a
x1 y1 :: g a
y1 <|> :: Product f g a -> Product f g a -> Product f g a
<|> Pair x2 :: f a
x2 y2 :: g a
y2 = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
x1 f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
x2) (g a
y1 g a -> g a -> g a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a
y2)

-- | @since 4.9.0.0
instance (Monad f, Monad g) => Monad (Product f g) where
    Pair m :: f a
m n :: g a
n >>= :: Product f g a -> (a -> Product f g b) -> Product f g b
>>= f :: a -> Product f g b
f = f b -> g b -> Product f g b
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
m f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Product f g b -> f b
forall k (f :: k -> *) (g :: k -> *) (a :: k). Product f g a -> f a
fstP (Product f g b -> f b) -> (a -> Product f g b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product f g b
f) (g a
n g a -> (a -> g b) -> g b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Product f g b -> g b
forall k (f :: k -> *) (g :: k -> *) (a :: k). Product f g a -> g a
sndP (Product f g b -> g b) -> (a -> Product f g b) -> a -> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product f g b
f)
      where
        fstP :: Product f g a -> f a
fstP (Pair a :: f a
a _) = f a
a
        sndP :: Product f g a -> g a
sndP (Pair _ b :: g a
b) = g a
b

-- | @since 4.9.0.0
instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
    mzero :: Product f g a
mzero = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
forall (m :: * -> *) a. MonadPlus m => m a
mzero g a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Pair x1 :: f a
x1 y1 :: g a
y1 mplus :: Product f g a -> Product f g a -> Product f g a
`mplus` Pair x2 :: f a
x2 y2 :: g a
y2 = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
x1 f a -> f a -> f a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` f a
x2) (g a
y1 g a -> g a -> g a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` g a
y2)

-- | @since 4.9.0.0
instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where
    mfix :: (a -> Product f g a) -> Product f g a
mfix f :: a -> Product f g a
f = f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> f a) -> f a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Product f g a -> f a
forall k (f :: k -> *) (g :: k -> *) (a :: k). Product f g a -> f a
fstP (Product f g a -> f a) -> (a -> Product f g a) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product f g a
f)) ((a -> g a) -> g a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Product f g a -> g a
forall k (f :: k -> *) (g :: k -> *) (a :: k). Product f g a -> g a
sndP (Product f g a -> g a) -> (a -> Product f g a) -> a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product f g a
f))
      where
        fstP :: Product f g a -> f a
fstP (Pair a :: f a
a _) = f a
a
        sndP :: Product f g a -> g a
sndP (Pair _ b :: g a
b) = g a
b

-- | @since 4.9.0.0
instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
    mzipWith :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c
mzipWith f :: a -> b -> c
f (Pair x1 :: f a
x1 y1 :: g a
y1) (Pair x2 :: f b
x2 y2 :: g b
y2) = f c -> g c -> Product f g c
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> b -> c) -> f a -> f b -> f c
forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith a -> b -> c
f f a
x1 f b
x2) ((a -> b -> c) -> g a -> g b -> g c
forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith a -> b -> c
f g a
y1 g b
y2)