1{-# LANGUAGE CPP #-} 2#if __GLASGOW_HASKELL__ >= 702 3{-# LANGUAGE DeriveGeneric #-} 4{-# LANGUAGE EmptyDataDecls #-} 5{-# LANGUAGE StandaloneDeriving #-} 6{-# LANGUAGE Trustworthy #-} 7{-# LANGUAGE TypeFamilies #-} 8{-# LANGUAGE TypeOperators #-} 9#endif 10#if __GLASGOW_HASKELL__ >= 706 11{-# LANGUAGE PolyKinds #-} 12#endif 13#if __GLASGOW_HASKELL__ >= 708 14{-# LANGUAGE AutoDeriveTypeable #-} 15{-# LANGUAGE DataKinds #-} 16{-# LANGUAGE DeriveDataTypeable #-} 17{-# LANGUAGE FlexibleContexts #-} 18{-# LANGUAGE KindSignatures #-} 19#endif 20----------------------------------------------------------------------------- 21-- | 22-- Module : Data.Functor.Compose 23-- Copyright : (c) Ross Paterson 2010 24-- License : BSD-style (see the file LICENSE) 25-- 26-- Maintainer : R.Paterson@city.ac.uk 27-- Stability : experimental 28-- Portability : portable 29-- 30-- Composition of functors. 31----------------------------------------------------------------------------- 32 33module Data.Functor.Compose ( 34 Compose(..), 35 ) where 36 37import Data.Functor.Classes 38#if MIN_VERSION_base(4,12,0) 39import Data.Functor.Contravariant 40#endif 41 42import Control.Applicative 43#if __GLASGOW_HASKELL__ >= 708 44import Data.Data 45#endif 46import Data.Foldable (Foldable(foldMap)) 47import Data.Traversable (Traversable(traverse)) 48#if __GLASGOW_HASKELL__ >= 702 49import GHC.Generics 50#endif 51 52infixr 9 `Compose` 53 54-- | Right-to-left composition of functors. 55-- The composition of applicative functors is always applicative, 56-- but the composition of monads is not always a monad. 57newtype Compose f g a = Compose { getCompose :: f (g a) } 58 59#if __GLASGOW_HASKELL__ >= 702 60deriving instance Generic (Compose f g a) 61 62instance Functor f => Generic1 (Compose f g) where 63 type Rep1 (Compose f g) = 64 D1 MDCompose 65 (C1 MCCompose 66 (S1 MSCompose (f :.: Rec1 g))) 67 from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) 68 to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) 69 70data MDCompose 71data MCCompose 72data MSCompose 73 74instance Datatype MDCompose where 75 datatypeName _ = "Compose" 76 moduleName _ = "Data.Functor.Compose" 77# if __GLASGOW_HASKELL__ >= 708 78 isNewtype _ = True 79# endif 80 81instance Constructor MCCompose where 82 conName _ = "Compose" 83 conIsRecord _ = True 84 85instance Selector MSCompose where 86 selName _ = "getCompose" 87#endif 88 89#if __GLASGOW_HASKELL__ >= 708 90deriving instance Typeable Compose 91deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) 92 => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) 93#endif 94 95-- Instances of lifted Prelude classes 96 97instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where 98 liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y 99 100instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where 101 liftCompare comp (Compose x) (Compose y) = 102 liftCompare (liftCompare comp) x y 103 104instance (Read1 f, Read1 g) => Read1 (Compose f g) where 105 liftReadsPrec rp rl = readsData $ 106 readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose 107 where 108 rp' = liftReadsPrec rp rl 109 rl' = liftReadList rp rl 110 111instance (Show1 f, Show1 g) => Show1 (Compose f g) where 112 liftShowsPrec sp sl d (Compose x) = 113 showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x 114 where 115 sp' = liftShowsPrec sp sl 116 sl' = liftShowList sp sl 117 118-- Instances of Prelude classes 119 120instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where 121 (==) = eq1 122 123instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where 124 compare = compare1 125 126instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where 127 readsPrec = readsPrec1 128 129instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where 130 showsPrec = showsPrec1 131 132-- Functor instances 133 134instance (Functor f, Functor g) => Functor (Compose f g) where 135 fmap f (Compose x) = Compose (fmap (fmap f) x) 136 137instance (Foldable f, Foldable g) => Foldable (Compose f g) where 138 foldMap f (Compose t) = foldMap (foldMap f) t 139 140instance (Traversable f, Traversable g) => Traversable (Compose f g) where 141 traverse f (Compose t) = Compose <$> traverse (traverse f) t 142 143instance (Applicative f, Applicative g) => Applicative (Compose f g) where 144 pure x = Compose (pure (pure x)) 145 Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) 146 147instance (Alternative f, Applicative g) => Alternative (Compose f g) where 148 empty = Compose empty 149 Compose x <|> Compose y = Compose (x <|> y) 150 151#if MIN_VERSION_base(4,12,0) 152instance (Functor f, Contravariant g) => Contravariant (Compose f g) where 153 contramap f (Compose fga) = Compose (fmap (contramap f) fga) 154#endif 155