ref: 52b1295c3c1922740b0ec68f633591e294c5c838
parent: b93bb68879a75debe906206abfa662d8ae7039d6
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Sep 22 07:13:21 EDT 2024
Add Product and Sum functors
--- /dev/null
+++ b/lib/Data/Functor/Product.hs
@@ -1,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 : libraries@haskell.org
+-- 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
--- /dev/null
+++ b/lib/Data/Functor/Sum.hs
@@ -1,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 : libraries@haskell.org
+-- 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
--
⑨