(original) (raw)

{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-}

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)

data Product f g a = Pair (f a) (g a) deriving ( Data
, Generic
, Generic1 )

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

instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where liftCompare comp (Pair x1 y1) (Pair x2 y2) = liftCompare comp x1 x2 [mappend](GHC.Base.html#mappend) liftCompare comp y1 y2

instance (Read1 f, Read1 g) => Read1 (Product f g) where liftReadPrec rp rl = readData $ readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Pair" Pair

[liftReadListPrec](Data.Functor.Classes.html#liftReadListPrec) = [liftReadListPrecDefault](Data.Functor.Classes.html#liftReadListPrecDefault)
[liftReadList](Data.Functor.Classes.html#liftReadList)     = [liftReadListDefault](Data.Functor.Classes.html#liftReadListDefault)

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

instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where (==) = eq1

instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where compare = compare1

instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where readPrec = readPrec1

[readListPrec](GHC.Read.html#readListPrec) = [readListPrecDefault](GHC.Read.html#readListPrecDefault)
[readList](GHC.Read.html#readList)     = [readListDefault](GHC.Read.html#readListDefault)

instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where showsPrec = showsPrec1

instance (Functor f, Functor g) => Functor (Product f g) where fmap f (Pair x y) = Pair (fmap f x) (fmap f y)

instance (Foldable f, Foldable g) => Foldable (Product f g) where foldMap f (Pair x y) = foldMap f x [mappend](GHC.Base.html#mappend) foldMap f y

instance (Traversable f, Traversable g) => Traversable (Product f g) where traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y)

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)

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)

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

instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where mzero = Pair mzero mzero Pair x1 y1 [mplus](GHC.Base.html#mplus) Pair x2 y2 = Pair (x1 [mplus](GHC.Base.html#mplus) x2) (y1 [mplus](GHC.Base.html#mplus) y2)

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

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)