{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 700
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Trustworthy #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DataKinds #-}
#endif
#if MIN_VERSION_base(4,7,0)
-- We need to implement bitSize for the Bits instance, but it's deprecated.
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Identity
-- Copyright   :  (c) Andy Gill 2001,
--                (c) Oregon Graduate Institute of Science and Technology 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  ross@soi.city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- The identity functor and monad.
--
-- This trivial type constructor serves two purposes:
--
-- * It can be used with functions parameterized by functor or monad classes.
--
-- * It can be used as a base monad to which a series of monad
--   transformers may be applied to construct a composite monad.
--   Most monad transformer modules include the special case of
--   applying the transformer to 'Identity'.  For example, @State s@
--   is an abbreviation for @StateT s 'Identity'@.
-----------------------------------------------------------------------------

module Data.Functor.Identity (
    Identity(..),
  ) where

import Data.Bits
import Control.Applicative
import Control.Arrow (Arrow((***)))
import Control.Monad.Fix
#if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip (MonadZip(mzipWith, munzip))
#endif
import Data.Foldable (Foldable(foldMap))
import Data.Monoid (Monoid(mempty, mappend))
import Data.String (IsString(fromString))
import Data.Traversable (Traversable(traverse))
#if __GLASGOW_HASKELL__ >= 700
import Data.Data
#endif
import Data.Ix (Ix(..))
import Foreign (Storable(..), castPtr)
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics
#endif

-- | Identity functor and monad. (a non-strict monad)
newtype Identity a = Identity { runIdentity :: a }
    deriving ( Eq, Ord
#if __GLASGOW_HASKELL__ >= 700
             , Data, Typeable
#endif
#if __GLASGOW_HASKELL__ >= 702
             , Generic
#endif
#if __GLASGOW_HASKELL__ >= 706
             , Generic1
#endif
             )

instance (Bits a) => Bits (Identity a) where
    Identity x .&. Identity y     = Identity (x .&. y)
    Identity x .|. Identity y     = Identity (x .|. y)
    xor (Identity x) (Identity y) = Identity (xor x y)
    complement   (Identity x)     = Identity (complement x)
    shift        (Identity x) i   = Identity (shift    x i)
    rotate       (Identity x) i   = Identity (rotate   x i)
    setBit       (Identity x) i   = Identity (setBit   x i)
    clearBit     (Identity x) i   = Identity (clearBit x i)
    shiftL       (Identity x) i   = Identity (shiftL   x i)
    shiftR       (Identity x) i   = Identity (shiftR   x i)
    rotateL      (Identity x) i   = Identity (rotateL  x i)
    rotateR      (Identity x) i   = Identity (rotateR  x i)
    testBit      (Identity x) i   = testBit x i
    bitSize      (Identity x)     = bitSize x
    isSigned     (Identity x)     = isSigned x
    bit i                         = Identity (bit i)
#if MIN_VERSION_base(4,5,0)
    unsafeShiftL (Identity x) i   = Identity (unsafeShiftL x i)
    unsafeShiftR (Identity x) i   = Identity (unsafeShiftR x i)
    popCount     (Identity x)     = popCount x
#endif
#if MIN_VERSION_base(4,7,0)
    zeroBits                      = Identity zeroBits
    bitSizeMaybe (Identity x)     = bitSizeMaybe x
#endif

instance (Bounded a) => Bounded (Identity a) where
    minBound = Identity minBound
    maxBound = Identity maxBound

instance (Enum a) => Enum (Identity a) where
    succ (Identity x)     = Identity (succ x)
    pred (Identity x)     = Identity (pred x)
    toEnum i              = Identity (toEnum i)
    fromEnum (Identity x) = fromEnum x
    enumFrom (Identity x) = map Identity (enumFrom x)
    enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y)
    enumFromTo   (Identity x) (Identity y) = map Identity (enumFromTo   x y)
    enumFromThenTo (Identity x) (Identity y) (Identity z) =
        map Identity (enumFromThenTo x y z)

#if MIN_VERSION_base(4,7,0)
instance (FiniteBits a) => FiniteBits (Identity a) where
    finiteBitSize (Identity x) = finiteBitSize x
#endif

instance (Floating a) => Floating (Identity a) where
    pi                                = Identity pi
    exp   (Identity x)                = Identity (exp x)
    log   (Identity x)                = Identity (log x)
    sqrt  (Identity x)                = Identity (sqrt x)
    sin   (Identity x)                = Identity (sin x)
    cos   (Identity x)                = Identity (cos x)
    tan   (Identity x)                = Identity (tan x)
    asin  (Identity x)                = Identity (asin x)
    acos  (Identity x)                = Identity (acos x)
    atan  (Identity x)                = Identity (atan x)
    sinh  (Identity x)                = Identity (sinh x)
    cosh  (Identity x)                = Identity (cosh x)
    tanh  (Identity x)                = Identity (tanh x)
    asinh (Identity x)                = Identity (asinh x)
    acosh (Identity x)                = Identity (acosh x)
    atanh (Identity x)                = Identity (atanh x)
    Identity x ** Identity y          = Identity (x ** y)
    logBase (Identity x) (Identity y) = Identity (logBase x y)

instance (Fractional a) => Fractional (Identity a) where
    Identity x / Identity y = Identity (x / y)
    recip (Identity x)      = Identity (recip x)
    fromRational r          = Identity (fromRational r)

instance (IsString a) => IsString (Identity a) where
    fromString s = Identity (fromString s)

instance (Ix a) => Ix (Identity a) where
    range     (Identity x, Identity y) = map Identity (range (x, y))
    index     (Identity x, Identity y) (Identity i) = index     (x, y) i
    inRange   (Identity x, Identity y) (Identity e) = inRange   (x, y) e
    rangeSize (Identity x, Identity y) = rangeSize (x, y)

instance (Integral a) => Integral (Identity a) where
    quot    (Identity x) (Identity y) = Identity (quot x y)
    rem     (Identity x) (Identity y) = Identity (rem  x y)
    div     (Identity x) (Identity y) = Identity (div  x y)
    mod     (Identity x) (Identity y) = Identity (mod  x y)
    quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y)
    divMod  (Identity x) (Identity y) = (Identity *** Identity) (divMod  x y)
    toInteger (Identity x)            = toInteger x

instance (Monoid a) => Monoid (Identity a) where
    mempty = Identity mempty
    mappend (Identity x) (Identity y) = Identity (mappend x y)

instance (Num a) => Num (Identity a) where
    Identity x + Identity y = Identity (x + y)
    Identity x - Identity y = Identity (x - y)
    Identity x * Identity y = Identity (x * y)
    negate (Identity x)     = Identity (negate x)
    abs    (Identity x)     = Identity (abs    x)
    signum (Identity x)     = Identity (signum x)
    fromInteger n           = Identity (fromInteger n)

instance (Real a) => Real (Identity a) where
    toRational (Identity x) = toRational x

instance (RealFloat a) => RealFloat (Identity a) where
    floatRadix     (Identity x)     = floatRadix     x
    floatDigits    (Identity x)     = floatDigits    x
    floatRange     (Identity x)     = floatRange     x
    decodeFloat    (Identity x)     = decodeFloat    x
    exponent       (Identity x)     = exponent       x
    isNaN          (Identity x)     = isNaN          x
    isInfinite     (Identity x)     = isInfinite     x
    isDenormalized (Identity x)     = isDenormalized x
    isNegativeZero (Identity x)     = isNegativeZero x
    isIEEE         (Identity x)     = isIEEE         x
    significand    (Identity x)     = significand (Identity x)
    scaleFloat s   (Identity x)     = Identity (scaleFloat s x)
    encodeFloat m n                 = Identity (encodeFloat m n)
    atan2 (Identity x) (Identity y) = Identity (atan2 x y)

instance (RealFrac a) => RealFrac (Identity a) where
    properFraction (Identity x) = (id *** Identity) (properFraction x)
    truncate       (Identity x) = truncate x
    round          (Identity x) = round    x
    ceiling        (Identity x) = ceiling  x
    floor          (Identity x) = floor    x

instance (Storable a) => Storable (Identity a) where
    sizeOf    (Identity x)       = sizeOf x
    alignment (Identity x)       = alignment x
    peekElemOff p i              = fmap Identity (peekElemOff (castPtr p) i)
    pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x
    peekByteOff p i              = fmap Identity (peekByteOff p i)
    pokeByteOff p i (Identity x) = pokeByteOff p i x
    peek p                       = fmap runIdentity (peek (castPtr p))
    poke p (Identity x)          = poke (castPtr p) x

-- These instances would be equivalent to the derived instances of the
-- newtype if the field were removed.

instance (Read a) => Read (Identity a) where
    readsPrec d = readParen (d > 10) $ \ r ->
        [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]

instance (Show a) => Show (Identity a) where
    showsPrec d (Identity x) = showParen (d > 10) $
        showString "Identity " . showsPrec 11 x

-- ---------------------------------------------------------------------------
-- Identity instances for Functor and Monad

instance Functor Identity where
    fmap f m = Identity (f (runIdentity m))

instance Foldable Identity where
    foldMap f (Identity x) = f x

instance Traversable Identity where
    traverse f (Identity x) = Identity <$> f x

instance Applicative Identity where
    pure a = Identity a
    Identity f <*> Identity x = Identity (f x)

instance Monad Identity where
    return a = Identity a
    m >>= k  = k (runIdentity m)

instance MonadFix Identity where
    mfix f = Identity (fix (runIdentity . f))

#if MIN_VERSION_base(4,4,0)
instance MonadZip Identity where
    mzipWith f (Identity x) (Identity y) = Identity (f x y)
    munzip (Identity (a, b)) = (Identity a, Identity b)
#endif