1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# 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 Data.Functor.Classes
import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Foldable (Foldable(..))
import Data.Monoid (Sum(..), All(..), Any(..), Product(..))
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
infixr 9 `Compose`
-- | Right-to-left composition of functors.
-- The composition of applicative functors is always applicative,
-- but the composition of monads is not always a monad.
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
)
-- Instances of Prelude classes
-- | @since 4.18.0.0
deriving instance Eq (f (g a)) => Eq (Compose f g a)
-- | @since 4.18.0.0
deriving instance Ord (f (g a)) => Ord (Compose f g a)
-- | @since 4.18.0.0
instance Read (f (g a)) => Read (Compose f g a) where
readPrec = liftReadPrecCompose readPrec
readListPrec = readListPrecDefault
readList = readListDefault
-- | @since 4.18.0.0
instance Show (f (g a)) => Show (Compose f g a) where
showsPrec = liftShowsPrecCompose showsPrec
-- Instances of lifted Prelude classes
-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
liftCompare comp (Compose x) (Compose y) =
liftCompare (liftCompare comp) x y
-- | @since 4.9.0.0
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
-- | @since 4.9.0.0
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
-- Functor instances
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Compose f g) where
traverse f (Compose t) = Compose <$> traverse (traverse f) t
-- | @since 4.9.0.0
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
(<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))
:: forall a . Compose f g a -> Compose f g a -> Compose f g a
-- | 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
|
