1{-# LANGUAGE CPP #-}
2#if __GLASGOW_HASKELL__ >= 700
3{-# LANGUAGE DeriveDataTypeable #-}
4#endif
5#if __GLASGOW_HASKELL__ >= 702
6{-# LANGUAGE DeriveGeneric #-}
7{-# LANGUAGE Trustworthy #-}
8#endif
9#if __GLASGOW_HASKELL__ >= 706
10{-# LANGUAGE PolyKinds #-}
11#endif
12#if __GLASGOW_HASKELL__ >= 708
13{-# LANGUAGE AutoDeriveTypeable #-}
14{-# LANGUAGE DataKinds #-}
15#endif
16#if MIN_VERSION_base(4,7,0)
17-- We need to implement bitSize for the Bits instance, but it's deprecated.
18{-# OPTIONS_GHC -fno-warn-deprecations #-}
19#endif
20-----------------------------------------------------------------------------
21-- |
22-- Module      :  Data.Functor.Identity
23-- Copyright   :  (c) Andy Gill 2001,
24--                (c) Oregon Graduate Institute of Science and Technology 2001
25-- License     :  BSD-style (see the file LICENSE)
26--
27-- Maintainer  :  ross@soi.city.ac.uk
28-- Stability   :  experimental
29-- Portability :  portable
30--
31-- The identity functor and monad.
32--
33-- This trivial type constructor serves two purposes:
34--
35-- * It can be used with functions parameterized by functor or monad classes.
36--
37-- * It can be used as a base monad to which a series of monad
38--   transformers may be applied to construct a composite monad.
39--   Most monad transformer modules include the special case of
40--   applying the transformer to 'Identity'.  For example, @State s@
41--   is an abbreviation for @StateT s 'Identity'@.
42-----------------------------------------------------------------------------
43
44module Data.Functor.Identity (
45    Identity(..),
46  ) where
47
48import Data.Bits
49import Control.Applicative
50import Control.Arrow (Arrow((***)))
51import Control.Monad.Fix
52#if MIN_VERSION_base(4,4,0)
53import Control.Monad.Zip (MonadZip(mzipWith, munzip))
54#endif
55import Data.Foldable (Foldable(foldMap))
56import Data.Monoid (Monoid(mempty, mappend))
57import Data.String (IsString(fromString))
58import Data.Traversable (Traversable(traverse))
59#if __GLASGOW_HASKELL__ >= 700
60import Data.Data
61#endif
62import Data.Ix (Ix(..))
63import Foreign (Storable(..), castPtr)
64#if __GLASGOW_HASKELL__ >= 702
65import GHC.Generics
66#endif
67
68-- | Identity functor and monad. (a non-strict monad)
69newtype Identity a = Identity { runIdentity :: a }
70    deriving ( Eq, Ord
71#if __GLASGOW_HASKELL__ >= 700
72             , Data, Typeable
73#endif
74#if __GLASGOW_HASKELL__ >= 702
75             , Generic
76#endif
77#if __GLASGOW_HASKELL__ >= 706
78             , Generic1
79#endif
80             )
81
82instance (Bits a) => Bits (Identity a) where
83    Identity x .&. Identity y     = Identity (x .&. y)
84    Identity x .|. Identity y     = Identity (x .|. y)
85    xor (Identity x) (Identity y) = Identity (xor x y)
86    complement   (Identity x)     = Identity (complement x)
87    shift        (Identity x) i   = Identity (shift    x i)
88    rotate       (Identity x) i   = Identity (rotate   x i)
89    setBit       (Identity x) i   = Identity (setBit   x i)
90    clearBit     (Identity x) i   = Identity (clearBit x i)
91    shiftL       (Identity x) i   = Identity (shiftL   x i)
92    shiftR       (Identity x) i   = Identity (shiftR   x i)
93    rotateL      (Identity x) i   = Identity (rotateL  x i)
94    rotateR      (Identity x) i   = Identity (rotateR  x i)
95    testBit      (Identity x) i   = testBit x i
96    bitSize      (Identity x)     = bitSize x
97    isSigned     (Identity x)     = isSigned x
98    bit i                         = Identity (bit i)
99#if MIN_VERSION_base(4,5,0)
100    unsafeShiftL (Identity x) i   = Identity (unsafeShiftL x i)
101    unsafeShiftR (Identity x) i   = Identity (unsafeShiftR x i)
102    popCount     (Identity x)     = popCount x
103#endif
104#if MIN_VERSION_base(4,7,0)
105    zeroBits                      = Identity zeroBits
106    bitSizeMaybe (Identity x)     = bitSizeMaybe x
107#endif
108
109instance (Bounded a) => Bounded (Identity a) where
110    minBound = Identity minBound
111    maxBound = Identity maxBound
112
113instance (Enum a) => Enum (Identity a) where
114    succ (Identity x)     = Identity (succ x)
115    pred (Identity x)     = Identity (pred x)
116    toEnum i              = Identity (toEnum i)
117    fromEnum (Identity x) = fromEnum x
118    enumFrom (Identity x) = map Identity (enumFrom x)
119    enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y)
120    enumFromTo   (Identity x) (Identity y) = map Identity (enumFromTo   x y)
121    enumFromThenTo (Identity x) (Identity y) (Identity z) =
122        map Identity (enumFromThenTo x y z)
123
124#if MIN_VERSION_base(4,7,0)
125instance (FiniteBits a) => FiniteBits (Identity a) where
126    finiteBitSize (Identity x) = finiteBitSize x
127#endif
128
129instance (Floating a) => Floating (Identity a) where
130    pi                                = Identity pi
131    exp   (Identity x)                = Identity (exp x)
132    log   (Identity x)                = Identity (log x)
133    sqrt  (Identity x)                = Identity (sqrt x)
134    sin   (Identity x)                = Identity (sin x)
135    cos   (Identity x)                = Identity (cos x)
136    tan   (Identity x)                = Identity (tan x)
137    asin  (Identity x)                = Identity (asin x)
138    acos  (Identity x)                = Identity (acos x)
139    atan  (Identity x)                = Identity (atan x)
140    sinh  (Identity x)                = Identity (sinh x)
141    cosh  (Identity x)                = Identity (cosh x)
142    tanh  (Identity x)                = Identity (tanh x)
143    asinh (Identity x)                = Identity (asinh x)
144    acosh (Identity x)                = Identity (acosh x)
145    atanh (Identity x)                = Identity (atanh x)
146    Identity x ** Identity y          = Identity (x ** y)
147    logBase (Identity x) (Identity y) = Identity (logBase x y)
148
149instance (Fractional a) => Fractional (Identity a) where
150    Identity x / Identity y = Identity (x / y)
151    recip (Identity x)      = Identity (recip x)
152    fromRational r          = Identity (fromRational r)
153
154instance (IsString a) => IsString (Identity a) where
155    fromString s = Identity (fromString s)
156
157instance (Ix a) => Ix (Identity a) where
158    range     (Identity x, Identity y) = map Identity (range (x, y))
159    index     (Identity x, Identity y) (Identity i) = index     (x, y) i
160    inRange   (Identity x, Identity y) (Identity e) = inRange   (x, y) e
161    rangeSize (Identity x, Identity y) = rangeSize (x, y)
162
163instance (Integral a) => Integral (Identity a) where
164    quot    (Identity x) (Identity y) = Identity (quot x y)
165    rem     (Identity x) (Identity y) = Identity (rem  x y)
166    div     (Identity x) (Identity y) = Identity (div  x y)
167    mod     (Identity x) (Identity y) = Identity (mod  x y)
168    quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y)
169    divMod  (Identity x) (Identity y) = (Identity *** Identity) (divMod  x y)
170    toInteger (Identity x)            = toInteger x
171
172instance (Monoid a) => Monoid (Identity a) where
173    mempty = Identity mempty
174    mappend (Identity x) (Identity y) = Identity (mappend x y)
175
176instance (Num a) => Num (Identity a) where
177    Identity x + Identity y = Identity (x + y)
178    Identity x - Identity y = Identity (x - y)
179    Identity x * Identity y = Identity (x * y)
180    negate (Identity x)     = Identity (negate x)
181    abs    (Identity x)     = Identity (abs    x)
182    signum (Identity x)     = Identity (signum x)
183    fromInteger n           = Identity (fromInteger n)
184
185instance (Real a) => Real (Identity a) where
186    toRational (Identity x) = toRational x
187
188instance (RealFloat a) => RealFloat (Identity a) where
189    floatRadix     (Identity x)     = floatRadix     x
190    floatDigits    (Identity x)     = floatDigits    x
191    floatRange     (Identity x)     = floatRange     x
192    decodeFloat    (Identity x)     = decodeFloat    x
193    exponent       (Identity x)     = exponent       x
194    isNaN          (Identity x)     = isNaN          x
195    isInfinite     (Identity x)     = isInfinite     x
196    isDenormalized (Identity x)     = isDenormalized x
197    isNegativeZero (Identity x)     = isNegativeZero x
198    isIEEE         (Identity x)     = isIEEE         x
199    significand    (Identity x)     = significand (Identity x)
200    scaleFloat s   (Identity x)     = Identity (scaleFloat s x)
201    encodeFloat m n                 = Identity (encodeFloat m n)
202    atan2 (Identity x) (Identity y) = Identity (atan2 x y)
203
204instance (RealFrac a) => RealFrac (Identity a) where
205    properFraction (Identity x) = (id *** Identity) (properFraction x)
206    truncate       (Identity x) = truncate x
207    round          (Identity x) = round    x
208    ceiling        (Identity x) = ceiling  x
209    floor          (Identity x) = floor    x
210
211instance (Storable a) => Storable (Identity a) where
212    sizeOf    (Identity x)       = sizeOf x
213    alignment (Identity x)       = alignment x
214    peekElemOff p i              = fmap Identity (peekElemOff (castPtr p) i)
215    pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x
216    peekByteOff p i              = fmap Identity (peekByteOff p i)
217    pokeByteOff p i (Identity x) = pokeByteOff p i x
218    peek p                       = fmap runIdentity (peek (castPtr p))
219    poke p (Identity x)          = poke (castPtr p) x
220
221-- These instances would be equivalent to the derived instances of the
222-- newtype if the field were removed.
223
224instance (Read a) => Read (Identity a) where
225    readsPrec d = readParen (d > 10) $ \ r ->
226        [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]
227
228instance (Show a) => Show (Identity a) where
229    showsPrec d (Identity x) = showParen (d > 10) $
230        showString "Identity " . showsPrec 11 x
231
232-- ---------------------------------------------------------------------------
233-- Identity instances for Functor and Monad
234
235instance Functor Identity where
236    fmap f m = Identity (f (runIdentity m))
237
238instance Foldable Identity where
239    foldMap f (Identity x) = f x
240
241instance Traversable Identity where
242    traverse f (Identity x) = Identity <$> f x
243
244instance Applicative Identity where
245    pure a = Identity a
246    Identity f <*> Identity x = Identity (f x)
247
248instance Monad Identity where
249    return a = Identity a
250    m >>= k  = k (runIdentity m)
251
252instance MonadFix Identity where
253    mfix f = Identity (fix (runIdentity . f))
254
255#if MIN_VERSION_base(4,4,0)
256instance MonadZip Identity where
257    mzipWith f (Identity x) (Identity y) = Identity (f x y)
258    munzip (Identity (a, b)) = (Identity a, Identity b)
259#endif
260