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