ref: b93bb68879a75debe906206abfa662d8ae7039d6
parent: b31503cbf57eb358a11397c4a7eeef9cdb221c3f
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Sep 22 07:02:35 EDT 2024
Add Data.Functor.Compose
--- a/Makefile
+++ b/Makefile
@@ -198,7 +198,7 @@
MCABALBIN=$(MCABAL)/bin
MDIST=dist-mcabal
BASE=base-$(VERSION)
-BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Const Data.Functor.Identity Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
+BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Const Data.Functor.Identity Data.Functor.Product Data.Functor.Sum Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
$(MCABALBIN)/mhs: bin/mhs
@mkdir -p $(MCABALBIN)
--- a/lib/AllOfLib.hs
+++ b/lib/AllOfLib.hs
@@ -32,8 +32,11 @@
import Data.Function
import Data.Functor
import Data.Functor.Classes
+import Data.Functor.Compose
import Data.Functor.Const
import Data.Functor.Identity
+import Data.Functor.Product
+import Data.Functor.Sum
import Data.IOArray
import Data.IORef
import Data.Int
@@ -50,6 +53,7 @@
import Data.Monoid
import Data.Num
import Data.Ord
+import Data.Orphans
import Data.Ordering_Type
import Data.Proxy
import Data.Ratio
--- /dev/null
+++ b/lib/Data/Functor/Compose.hs
@@ -1,0 +1,170 @@
+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE StandaloneDeriving #-}+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Functor.Compose
+-- Copyright : (c) Ross Paterson 2010
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : stable
+-- Portability : portable
+--
+-- Composition of functors.
+--
+-- @since 4.9.0.0
+-----------------------------------------------------------------------------
+
+module Data.Functor.Compose (
+ Compose(..),
+ ) where
+import Prelude hiding(foldr, foldl, null, length, elem, maximum, minimum, sum, product)
+import Control.Applicative
+--import Data.Coerce (coerce)
+import Data.Data (Data)
+import Data.Foldable (Foldable(..))
+import Data.Functor.Classes
+import Data.Monoid
+import Data.Traversable
+--import Data.Type.Equality (TestEquality(..), (:~:)(..))
+--import GHC.Generics (Generic, Generic1)
+import Text.Read.Internal(Read(..), ReadPrec, readListDefault, readListPrecDefault)
+
+infixr 9 `Compose`
+
+newtype Compose f g a = Compose { getCompose :: f (g a) }+{-+ deriving ( Data -- ^ @since 4.9.0.0
+ , Generic -- ^ @since 4.9.0.0
+ , Generic1 -- ^ @since 4.9.0.0
+ , Semigroup -- ^ @since 4.16.0.0
+ , Monoid -- ^ @since 4.16.0.0
+ )
+
+deriving instance Eq (f (g a)) => Eq (Compose f g a)
+deriving instance Ord (f (g a)) => Ord (Compose f g a)
+
+instance Read (f (g a)) => Read (Compose f g a) where
+ readPrec = liftReadPrecCompose readPrec
+
+ readListPrec = readListPrecDefault
+ readList = readListDefault
+-}
+instance Eq (f (g a)) => Eq (Compose f g a) where
+ Compose x == Compose y = x == y
+
+instance Ord (f (g a)) => Ord (Compose f g a) where
+ Compose x `compare` Compose y = x `compare` y
+
+instance Show (f (g a)) => Show (Compose f g a) where
+ showsPrec = liftShowsPrecCompose showsPrec
+
+instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
+ liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
+
+instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
+ liftCompare comp (Compose x) (Compose y) =
+ liftCompare (liftCompare comp) x y
+
+{-+instance (Read1 f, Read1 g) => Read1 (Compose f g) where
+ liftReadPrec rp rl =
+ liftReadPrecCompose (liftReadPrec rp' rl')
+ where
+ rp' = liftReadPrec rp rl
+ rl' = liftReadListPrec rp rl
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+-}
+
+instance (Show1 f, Show1 g) => Show1 (Compose f g) where
+ liftShowsPrec sp sl =
+ liftShowsPrecCompose (liftShowsPrec sp' sl')
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+{-+-- The workhorse for Compose's Read and Read1 instances.
+liftReadPrecCompose :: ReadPrec (f (g a)) -> ReadPrec (Compose f g a)
+liftReadPrecCompose rp = readData $ readUnaryWith rp "Compose" Compose
+-}
+
+-- The workhorse for Compose's Show and Show1 instances.
+liftShowsPrecCompose :: (Int -> f (g a) -> ShowS) -> Int -> Compose f g a -> ShowS
+liftShowsPrecCompose sp d (Compose x) = showsUnaryWith sp "Compose" d x
+
+instance (Functor f, Functor g) => Functor (Compose f g) where
+ fmap f (Compose x) = Compose (fmap (fmap f) x)
+ a <$ (Compose x) = Compose (fmap (a <$) x)
+
+instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+ fold (Compose t) = foldMap fold t
+ foldMap f (Compose t) = foldMap (foldMap f) t
+ foldMap' f (Compose t) = foldMap' (foldMap' f) t
+ foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga
+ foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga
+ foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga
+ foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga
+
+ null (Compose t) = null t || getAll (foldMap (All . null) t)
+ length (Compose t) = getSum (foldMap' (Sum . length) t)
+ elem x (Compose t) = getAny (foldMap (Any . elem x) t)
+
+ minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga
+ maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga
+
+ sum (Compose t) = getSum (foldMap' (Sum . sum) t)
+ product (Compose t) = getProduct (foldMap' (Product . product) t)
+
+instance (Traversable f, Traversable g) => Traversable (Compose f g) where
+ traverse f (Compose t) = Compose <$> traverse (traverse f) t
+
+instance (Applicative f, Applicative g) => Applicative (Compose f g) where
+ pure x = Compose (pure (pure x))
+ Compose f <*> Compose x = Compose (liftA2 (<*>) f x)
+ liftA2 f (Compose x) (Compose y) =
+ Compose (liftA2 (liftA2 f) x y)
+
+-- | @since 4.9.0.0
+instance (Alternative f, Applicative g) => Alternative (Compose f g) where
+ empty = Compose empty
+ Compose x <|> Compose y = Compose (x <|> y)
+
+{-+-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.
+--
+-- @since 4.14.0.0
+instance (TestEquality f) => TestEquality (Compose f g) where
+ testEquality (Compose x) (Compose y) =
+ case testEquality x y of -- :: Maybe (g x :~: g y)
+ Just Refl -> Just Refl -- :: Maybe (x :~: y)
+ Nothing -> Nothing
+
+-- | @since 4.19.0.0
+deriving instance Enum (f (g a)) => Enum (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Bounded (f (g a)) => Bounded (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Num (f (g a)) => Num (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Real (f (g a)) => Real (Compose f g a)
+-- | @since 4.19.0.0
+deriving instance Integral (f (g a)) => Integral (Compose f g a)
+-- | @since 4.20.0.0
+deriving instance Fractional (f (g a)) => Fractional (Compose f g a)
+-- | @since 4.20.0.0
+deriving instance RealFrac (f (g a)) => RealFrac (Compose f g a)
+-- | @since 4.20.0.0
+deriving instance Floating (f (g a)) => Floating (Compose f g a)
+-- | @since 4.20.0.0
+deriving instance RealFloat (f (g a)) => RealFloat (Compose f g a)
+-}