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