Data/Functor/Product.hs

    {-# 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.Foldable (Foldable(foldMap))
    import Data.Functor.Classes
    import Data.Monoid (mappend)
    import Data.Traversable (Traversable(traverse))
    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, Generic, Generic1)

    -- | @since 4.9.0.0
    instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
        liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2

    -- | @since 4.9.0.0
    instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
        liftCompare comp (Pair x1 y1) (Pair x2 y2) =
            liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2

    -- | @since 4.9.0.0
    instance (Read1 f, Read1 g) => Read1 (Product f g) where
        liftReadPrec rp rl = readData $
            readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Pair" Pair

        liftReadListPrec = liftReadListPrecDefault
        liftReadList     = liftReadListDefault

    -- | @since 4.9.0.0
    instance (Show1 f, Show1 g) => Show1 (Product f g) where
        liftShowsPrec sp sl d (Pair x y) =
            showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y

    -- | @since 4.9.0.0
    instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
        where (==) = eq1

    -- | @since 4.9.0.0
    instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
        compare = compare1

    -- | @since 4.9.0.0
    instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
        readPrec = readPrec1

        readListPrec = readListPrecDefault
        readList     = readListDefault

    -- | @since 4.9.0.0
    instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
        showsPrec = showsPrec1

    -- | @since 4.9.0.0
    instance (Functor f, Functor g) => Functor (Product f g) where
        fmap f (Pair x y) = Pair (fmap f x) (fmap f y)

    -- | @since 4.9.0.0
    instance (Foldable f, Foldable g) => Foldable (Product f g) where
        foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y

    -- | @since 4.9.0.0
    instance (Traversable f, Traversable g) => Traversable (Product f g) where
        traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y)

    -- | @since 4.9.0.0
    instance (Applicative f, Applicative g) => Applicative (Product f g) where
        pure x = Pair (pure x) (pure x)
        Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)
        liftA2 f (Pair a b) (Pair x y) = Pair (liftA2 f a x) (liftA2 f b y)

    -- | @since 4.9.0.0
    instance (Alternative f, Alternative g) => Alternative (Product f g) where
        empty = Pair empty empty
        Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)

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

    -- | @since 4.9.0.0
    instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
        mzero = Pair mzero mzero
        Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)

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

    -- | @since 4.9.0.0
    instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
        mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)