1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE Trustworthy #-}
7{-# LANGUAGE TypeOperators #-}
8-----------------------------------------------------------------------------
9-- |
10-- Module      :  Data.Functor.Compose
11-- Copyright   :  (c) Ross Paterson 2010
12-- License     :  BSD-style (see the file LICENSE)
13--
14-- Maintainer  :  libraries@haskell.org
15-- Stability   :  experimental
16-- Portability :  portable
17--
18-- Composition of functors.
19--
20-- @since 4.9.0.0
21-----------------------------------------------------------------------------
22
23module Data.Functor.Compose (
24    Compose(..),
25  ) where
26
27import Data.Functor.Classes
28
29import Control.Applicative
30import Data.Coerce (coerce)
31import Data.Data (Data)
32import Data.Type.Equality (TestEquality(..), (:~:)(..))
33import GHC.Generics (Generic, Generic1)
34import Text.Read (Read(..), readListDefault, readListPrecDefault)
35
36infixr 9 `Compose`
37
38-- | Right-to-left composition of functors.
39-- The composition of applicative functors is always applicative,
40-- but the composition of monads is not always a monad.
41newtype Compose f g a = Compose { getCompose :: f (g a) }
42  deriving ( Data     -- ^ @since 4.9.0.0
43           , Generic  -- ^ @since 4.9.0.0
44           , Generic1 -- ^ @since 4.9.0.0
45           )
46
47-- Instances of lifted Prelude classes
48
49-- | @since 4.9.0.0
50instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
51    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
52
53-- | @since 4.9.0.0
54instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
55    liftCompare comp (Compose x) (Compose y) =
56        liftCompare (liftCompare comp) x y
57
58-- | @since 4.9.0.0
59instance (Read1 f, Read1 g) => Read1 (Compose f g) where
60    liftReadPrec rp rl = readData $
61        readUnaryWith (liftReadPrec rp' rl') "Compose" Compose
62      where
63        rp' = liftReadPrec     rp rl
64        rl' = liftReadListPrec rp rl
65
66    liftReadListPrec = liftReadListPrecDefault
67    liftReadList     = liftReadListDefault
68
69-- | @since 4.9.0.0
70instance (Show1 f, Show1 g) => Show1 (Compose f g) where
71    liftShowsPrec sp sl d (Compose x) =
72        showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
73      where
74        sp' = liftShowsPrec sp sl
75        sl' = liftShowList sp sl
76
77-- Instances of Prelude classes
78
79-- | @since 4.9.0.0
80instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
81    (==) = eq1
82
83-- | @since 4.9.0.0
84instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
85    compare = compare1
86
87-- | @since 4.9.0.0
88instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
89    readPrec = readPrec1
90
91    readListPrec = readListPrecDefault
92    readList     = readListDefault
93
94-- | @since 4.9.0.0
95instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
96    showsPrec = showsPrec1
97
98-- Functor instances
99
100-- | @since 4.9.0.0
101instance (Functor f, Functor g) => Functor (Compose f g) where
102    fmap f (Compose x) = Compose (fmap (fmap f) x)
103    a <$ (Compose x) = Compose (fmap (a <$) x)
104
105-- | @since 4.9.0.0
106instance (Foldable f, Foldable g) => Foldable (Compose f g) where
107    foldMap f (Compose t) = foldMap (foldMap f) t
108
109-- | @since 4.9.0.0
110instance (Traversable f, Traversable g) => Traversable (Compose f g) where
111    traverse f (Compose t) = Compose <$> traverse (traverse f) t
112
113-- | @since 4.9.0.0
114instance (Applicative f, Applicative g) => Applicative (Compose f g) where
115    pure x = Compose (pure (pure x))
116    Compose f <*> Compose x = Compose (liftA2 (<*>) f x)
117    liftA2 f (Compose x) (Compose y) =
118      Compose (liftA2 (liftA2 f) x y)
119
120-- | @since 4.9.0.0
121instance (Alternative f, Applicative g) => Alternative (Compose f g) where
122    empty = Compose empty
123    (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))
124      :: forall a . Compose f g a -> Compose f g a -> Compose f g a
125
126-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.
127--
128-- @since 4.14.0.0
129instance (TestEquality f) => TestEquality (Compose f g) where
130  testEquality (Compose x) (Compose y) =
131    case testEquality x y of -- :: Maybe (g x :~: g y)
132      Just Refl -> Just Refl -- :: Maybe (x :~: y)
133      Nothing   -> Nothing
134