{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE NoImplicitPrelude #-}

#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Int.Int24
-- Copyright   :  (c) The University of Glasgow 1997-2002
-- License     :  see src/Data/LICENSE
--
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- The 24 bit integral datatype, 'Int24'.
--
-----------------------------------------------------------------------------

module Data.Int.Int24 (
  -- * Int24 type
  Int24(..)
  -- * Internal helper
  , narrow24Int#
  ) where

import           Data.Bits
import           Data.Data
import           Data.Maybe
import           Data.Word.Word24
import           Foreign.Storable

import           GHC.Arr
import           GHC.Base
import           GHC.Enum
import           GHC.Int
import           GHC.Num
import           GHC.Ptr
import           GHC.Read
import           GHC.Real
import           GHC.Show
import           GHC.Word

import           Control.DeepSeq

#if !MIN_VERSION_base(4,8,0)
import           Data.Typeable
#endif

------------------------------------------------------------------------

-- Int24 is represented in the same way as Int. Operations may assume
-- and must ensure that it holds only values from its logical range.

-- | 24-bit signed integer type
data Int24 = I24# Int# deriving (Eq, Ord)

#if !MIN_VERSION_base(4,8,0)
deriving instance Typeable Int24
#endif

instance NFData Int24  where rnf !_ = ()

int24Type :: DataType
int24Type = mkIntType "Data.Word.Int24.Int24"

instance Data Int24 where
  toConstr x = mkIntegralConstr int24Type x
  gunfold _ z c = case constrRep c of
                    (IntConstr x) -> z (fromIntegral x)
                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c
                                 ++ " is not of type Int24."
  dataTypeOf _ = int24Type

-- the narrowings are primops in GHC; I don't have that luxury.
-- if the 24th bit (from right) is on, the value is negative, so
-- fill the uppermost bits with 1s.  Otherwise clear them to 0s.
narrow24Int# :: Int# -> Int#
narrow24Int# x# = if isTrue# ((x'# `and#` mask#) `eqWord#` mask#)
    then word2Int# (x'# `or#`  int2Word# m1#)
    else word2Int# (x'# `and#` int2Word# m2#)
  where
    !x'#   = int2Word# x#
    !mask# = int2Word# 0x00800000#
    !(I# m1#) = -8388608
    !(I# m2#) = 16777215

instance Show Int24 where
    showsPrec p x = showsPrec p (fromIntegral x :: Int)

instance Num Int24 where
    (I24# x#) + (I24# y#)  = I24# (narrow24Int# (x# +# y#))
    (I24# x#) - (I24# y#)  = I24# (narrow24Int# (x# -# y#))
    (I24# x#) * (I24# y#)  = I24# (narrow24Int# (x# *# y#))
    negate (I24# x#)       = I24# (narrow24Int# (negateInt# x#))
    abs x | x >= 0         = x
          | otherwise      = negate x
    signum x | x > 0       = 1
    signum 0               = 0
    signum _               = -1
    fromInteger i          = I24# (narrow24Int# (integerToInt i))

instance Real Int24 where
    toRational x = toInteger x % 1

instance Enum Int24 where
    succ x
        | x /= maxBound = x + 1
        | otherwise     = succError "Int24"
    pred x
        | x /= minBound = x - 1
        | otherwise     = predError "Int24"
    toEnum i@(I# i#)
        | i >= fromIntegral (minBound::Int24) && i <= fromIntegral (maxBound::Int24)
                        = I24# i#
        | otherwise     = toEnumError "Int24" i (minBound::Int24, maxBound::Int24)
    fromEnum (I24# x#)  = I# x#
    enumFrom            = boundedEnumFrom
    enumFromThen        = boundedEnumFromThen

instance Integral Int24 where
    quot    x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = I24# (narrow24Int# (x# `quotInt#` y#))
    rem     x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = I24# (narrow24Int# (x# `remInt#` y#))
    div     x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = I24# (narrow24Int# (x# `divInt#` y#))
    mod     x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = I24# (narrow24Int# (x# `modInt#` y#))
    quotRem x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = (I24# (narrow24Int# (x# `quotInt#` y#)),
                                        I24# (narrow24Int# (x# `remInt#` y#)))
    divMod  x@(I24# x#) y@(I24# y#)
        | y == 0                     = divZeroError
        | x == minBound && y == (-1) = overflowError
        | otherwise                  = (I24# (narrow24Int# (x# `divInt#` y#)),
                                        I24# (narrow24Int# (x# `modInt#` y#)))
    toInteger (I24# x#)              = smallInteger x#

instance Bounded Int24 where
    minBound = -0x800000
    maxBound =  0x7FFFFF

instance Ix Int24 where
    range (m,n)         = [m..n]
    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m
    inRange (m,n) i     = m <= i && i <= n

instance Read Int24 where
    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]

instance Bits Int24 where
    {-# INLINE shift #-}
    {-# INLINE bit #-}
    {-# INLINE testBit #-}

    (I24# x#) .&.   (I24# y#)  = I24# (word2Int# (int2Word# x# `and#` int2Word# y#))
    (I24# x#) .|.   (I24# y#)  = I24# (word2Int# (int2Word# x# `or#`  int2Word# y#))
    (I24# x#) `xor` (I24# y#)  = I24# (word2Int# (int2Word# x# `xor#` int2Word# y#))
    complement (I24# x#)       = I24# (word2Int# (not# (int2Word# x#)))
    (I24# x#) `shift` (I# i#)
        | isTrue# (i# >=# 0#)  = I24# (narrow24Int# (x# `iShiftL#` i#))
        | otherwise            = I24# (x# `iShiftRA#` negateInt# i#)
    (I24# x#) `shiftL`       (I# i#) = I24# (narrow24Int# (x# `iShiftL#` i#))
    (I24# x#) `unsafeShiftL` (I# i#) = I24# (narrow24Int# (x# `uncheckedIShiftL#` i#))
    (I24# x#) `shiftR`       (I# i#) = I24# (x# `iShiftRA#` i#)
    (I24# x#) `unsafeShiftR` (I# i#) = I24# (x# `uncheckedIShiftRA#` i#)
    (I24# x#) `rotate` i
        | isTrue# (i'# ==# 0#) = I24# x#
        | otherwise = I24# (narrow24Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
                                         (x'# `uncheckedShiftRL#` (24# -# i'#)))))
      where
        !x'# = narrow24Word# (int2Word# x#)
        !(I# i'#) = i `mod` 24
    bitSizeMaybe i             = Just (finiteBitSize i)
    bitSize                    = finiteBitSize
    isSigned _                 = True
    popCount (I24# x#)         = I# (word2Int# (popCnt24# (int2Word# x#)))
    bit                        = bitDefault
    testBit                    = testBitDefault

instance FiniteBits Int24 where
    finiteBitSize _ = 24
#if MIN_VERSION_base(4,8,0)
    countLeadingZeros  (I24# x#) = I# (word2Int# (clz24# (int2Word# x#)))
    countTrailingZeros (I24# x#) = I# (word2Int# (ctz24# (int2Word# x#)))
#endif

{-# RULES
"fromIntegral/Word8->Int24"   fromIntegral = \(W8# x#) -> I24# (word2Int# x#)
"fromIntegral/Word16->Int24"  fromIntegral = \(W16# x#) -> I24# (word2Int# x#)
"fromIntegral/Int8->Int24"    fromIntegral = \(I8# x#) -> I24# x#
"fromIntegral/Int16->Int24"   fromIntegral = \(I16# x#) -> I24# x#
"fromIntegral/Int24->Int24"   fromIntegral = id :: Int24 -> Int24
"fromIntegral/a->Int24"       fromIntegral = \x -> case fromIntegral x of I# x# -> I24# (narrow24Int# x#)
"fromIntegral/Int24->a"       fromIntegral = \(I24# x#) -> fromIntegral (I# x#)
  #-}

{-# RULES
"properFraction/Float->(Int24,Float)"
    properFraction = \x ->
                      case properFraction x of {
                        (n, y) -> ((fromIntegral :: Int -> Int24) n, y :: Float) }
"truncate/Float->Int24"
    truncate = (fromIntegral :: Int -> Int24) . (truncate :: Float -> Int)
"floor/Float->Int24"
    floor    = (fromIntegral :: Int -> Int24) . (floor :: Float -> Int)
"ceiling/Float->Int24"
    ceiling  = (fromIntegral :: Int -> Int24) . (ceiling :: Float -> Int)
"round/Float->Int24"
    round    = (fromIntegral :: Int -> Int24) . (round  :: Float -> Int)
  #-}

{-# RULES
"properFraction/Double->(Int24,Double)"
    properFraction = \x ->
                      case properFraction x of {
                        (n, y) -> ((fromIntegral :: Int -> Int24) n, y :: Double) }
"truncate/Double->Int24"
    truncate = (fromIntegral :: Int -> Int24) . (truncate :: Double -> Int)
"floor/Double->Int24"
    floor    = (fromIntegral :: Int -> Int24) . (floor :: Double -> Int)
"ceiling/Double->Int24"
    ceiling  = (fromIntegral :: Int -> Int24) . (ceiling :: Double -> Int)
"round/Double->Int24"
    round    = (fromIntegral :: Int -> Int24) . (round  :: Double -> Int)
  #-}

instance Storable Int24 where
  sizeOf _ = 3
  alignment _ = 3
  peek p = fmap fromIntegral $ peek ((castPtr p) :: Ptr Word24)
  poke p v = poke (castPtr p :: Ptr Word24) (fromIntegral v)