Backport Num/Bits/IsString/etc. instances for Identity
authorryan.gl.scott <ryan.gl.scott@gmail.com>
Mon, 11 Apr 2016 14:01:55 +0000 (14:01 +0000)
committerryan.gl.scott <ryan.gl.scott@gmail.com>
Mon, 11 Apr 2016 14:01:55 +0000 (14:01 +0000)
These instances were added in `base-4.9`
(see http://git.haskell.org/ghc.git/commit/8b57cac5974c9fffccbcae3104b5b5d18760749e)

legacy/pre709/Data/Functor/Identity.hs

index 63b1bd9..940e4e4 100644 (file)
 {-# 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
@@ -41,13 +45,16 @@ 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
@@ -72,6 +79,33 @@ newtype Identity a = Identity { runIdentity :: a }
 #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
@@ -87,26 +121,92 @@ instance (Enum a) => Enum (Identity a) where
     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)
 
--- These instances would be equivalent to the derived instances of the
--- newtype if the field were removed.
+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 (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 (Real a) => Real (Identity a) where
+    toRational (Identity x) = toRational x
 
-instance (Show a) => Show (Identity a) where
-    showsPrec d (Identity x) = showParen (d > 10) $
-        showString "Identity " . showsPrec 11 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
@@ -118,6 +218,17 @@ instance (Storable a) => Storable (Identity a) where
     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