Add Product and Sum functors

lib/Data/Functor/Product.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE StandaloneDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Functor.Product
+-- Copyright   :  (c) Ross Paterson 2010
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  [email protected]
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- Products, lifted to functors.
+--
+-- @since 4.9.0.0
+-----------------------------------------------------------------------------
+
+module Data.Functor.Product (
+    Product(..),
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Zip
+--import Data.Data (Data)
+import Data.Foldable
+import Data.Functor.Classes
+import Data.Monoid(Monoid(..))
+import Data.Traversable
+--import GHC.Generics (Generic, Generic1)
+
+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.18.0.0
+deriving instance (Eq (f a), Eq (g a)) => Eq (Product f g a)
+-- | @since 4.18.0.0
+deriving instance (Ord (f a), Ord (g a)) => Ord (Product f g a)
+-- | @since 4.18.0.0
+deriving instance (Read (f a), Read (g a)) => Read (Product f g a)
+-- | @since 4.18.0.0
+deriving instance (Show (f a), Show (g a)) => Show (Product f g a)
+-}
+
+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` 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 = liftReadListPrecDefault
+    liftReadList     = 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 (Functor f, Functor g) => Functor (Product f g) where
+    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
+    a <$ (Pair x y) = Pair (a <$ x) (a <$ y)
+
+instance (Foldable f, Foldable g) => Foldable (Product f g) where
+    foldMap f (Pair x y) = foldMap f x `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` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `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)
+
+instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Product f g a) where
+    Pair x1 y1 <> Pair x2 y2 = Pair (x1 <> x2) (y1 <> y2)
+
+instance (Monoid (f a), Monoid (g a)) => Monoid (Product f g a) where
+    mempty = Pair mempty mempty

lib/Data/Functor/Sum.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE StandaloneDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Functor.Sum
+-- Copyright   :  (c) Ross Paterson 2014
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  [email protected]
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- Sums, lifted to functors.
+--
+-- @since 4.9.0.0
+-----------------------------------------------------------------------------
+
+module Data.Functor.Sum (
+    Sum(..),
+  ) where
+import Control.Applicative ((<|>))
+--import Data.Data (Data)
+import Data.Foldable
+import Data.Functor.Classes
+import Data.Traversable
+--import GHC.Generics (Generic, Generic1)
+
+-- | Lifted sum of functors.
+--
+-- ==== __Examples__
+--
+-- >>> fmap (+1) (InL (Just 1))  :: Sum Maybe [] Int
+-- InL (Just 2)
+--
+-- >>> fmap (+1) (InR [1, 2, 3]) :: Sum Maybe [] Int
+-- InR [2,3,4]
+data Sum f g a = InL (f a) | InR (g a)
+{-
+  deriving ( Data     -- ^ @since 4.9.0.0
+           , Generic  -- ^ @since 4.9.0.0
+           , Generic1 -- ^ @since 4.9.0.0
+           )
+
+-- | @since 4.18.0.0
+deriving instance (Eq (f a), Eq (g a)) => Eq (Sum f g a)
+-- | @since 4.18.0.0
+deriving instance (Ord (f a), Ord (g a)) => Ord (Sum f g a)
+-- | @since 4.18.0.0
+deriving instance (Read (f a), Read (g a)) => Read (Sum f g a)
+-- | @since 4.18.0.0
+deriving instance (Show (f a), Show (g a)) => Show (Sum f g a)
+-}
+
+-- | @since 4.9.0.0
+instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where
+    liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2
+    liftEq _ (InL _) (InR _) = False
+    liftEq _ (InR _) (InL _) = False
+    liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2
+
+-- | @since 4.9.0.0
+instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where
+    liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2
+    liftCompare _ (InL _) (InR _) = LT
+    liftCompare _ (InR _) (InL _) = GT
+    liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2
+
+-- | @since 4.9.0.0
+instance (Read1 f, Read1 g) => Read1 (Sum f g) where
+    liftReadPrec rp rl = readData $
+        readUnaryWith (liftReadPrec rp rl) "InL" InL <|>
+        readUnaryWith (liftReadPrec rp rl) "InR" InR
+
+    liftReadListPrec = liftReadListPrecDefault
+    liftReadList     = liftReadListDefault
+
+-- | @since 4.9.0.0
+instance (Show1 f, Show1 g) => Show1 (Sum f g) where
+    liftShowsPrec sp sl d (InL x) =
+        showsUnaryWith (liftShowsPrec sp sl) "InL" d x
+    liftShowsPrec sp sl d (InR y) =
+        showsUnaryWith (liftShowsPrec sp sl) "InR" d y
+
+-- | @since 4.9.0.0
+instance (Functor f, Functor g) => Functor (Sum f g) where
+    fmap f (InL x) = InL (fmap f x)
+    fmap f (InR y) = InR (fmap f y)
+
+    a <$ (InL x) = InL (a <$ x)
+    a <$ (InR y) = InR (a <$ y)
+
+-- | @since 4.9.0.0
+instance (Foldable f, Foldable g) => Foldable (Sum f g) where
+    foldMap f (InL x) = foldMap f x
+    foldMap f (InR y) = foldMap f y
+
+-- | @since 4.9.0.0
+instance (Traversable f, Traversable g) => Traversable (Sum f g) where
+    traverse f (InL x) = InL <$> traverse f x
+    traverse f (InR y) = InR <$> traverse f y