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

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

-- |
-- Module      : Data.Word.Word24
-- License     : see  src/Data/LICENSE
-- Stability   : experimental
-- Portability : non-portable (GHC Extensions)

-- Provide a 24-bit unsigned integral type: 'Word24', analagous to Word8,
-- Word16, etc.
--

module Data.Word.Word24 (
  -- * Word24 type
    Word24(..)
  , byteSwap24
  , byteSwap24#
  -- * Internal helpers
  , narrow24Word#
#if MIN_VERSION_base(4,8,0)
  , clz24#
  , ctz24#
#endif
  , popCnt24#
  )

where

import           Data.Bits
import           Data.Data
import           Data.Maybe
import           Foreign.Storable

import           GHC.Arr
import           GHC.Base
import           GHC.Enum
import           GHC.Num hiding (integerToWord)
import           GHC.Ptr
import           GHC.Read
import           GHC.Real
import           GHC.Show
import           GHC.Word.Compat
import           GHC.Integer (smallInteger, integerToWord)

import           Control.DeepSeq

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

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

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

-- | 24-bit unsigned integer type
--
data Word24 = W24# Word# deriving (Eq, Ord)

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

instance NFData Word24 where rnf !_ = ()

word24Type :: DataType
word24Type = mkIntType "Data.Word.Word24.Word24"

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

-- | narrowings represented as primop 'and#' in GHC.
narrow24Word# :: Word# -> Word#
narrow24Word# = and# 0xFFFFFF##

#if MIN_VERSION_base(4,8,0)
-- | count leading zeros
--
clz24# :: Word# -> Word#
clz24# w# = clz32# (narrow24Word# w#) `minusWord#` 8##

-- | count trailing zeros
--
ctz24# :: Word# -> Word#
ctz24# w# = ctz# (w# `or#` 0x1000000##)
#endif

-- | the number of set bits
--
popCnt24# :: Word# -> Word#
popCnt24# w# = popCnt# (narrow24Word# w#)

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

instance Num Word24 where
  (W24# x#) + (W24# y#) = W24# (narrow24Word# (x# `plusWord#` y#))
  (W24# x#) - (W24# y#) = W24# (narrow24Word# (x# `minusWord#` y#))
  (W24# x#) * (W24# y#) = W24# (narrow24Word# (x# `timesWord#` y#))
  negate (W24# x#)      = W24# (narrow24Word# (int2Word# (negateInt# (word2Int# x#))))
  abs x                 = x
  signum 0              = 0
  signum _              = 1
  fromInteger i         = W24# (narrow24Word# (integerToWord i))

instance Real Word24 where
  toRational x = toInteger x % 1

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

instance Integral Word24 where
  quot (W24# x#) y@(W24# y#)
    | y /= 0                 = W24# (x# `quotWord#` y#)
    | otherwise              = divZeroError
  rem (W24# x#) y@(W24# y#)
    | y /= 0                 = W24# (x# `remWord#` y#)
    | otherwise              = divZeroError
  div (W24# x#) y@(W24# y#)
    | y /= 0                 = W24# (x# `quotWord#` y#)
    | otherwise              = divZeroError
  mod (W24# x#) y@(W24# y#)
    | y /= 0                 = W24# (x# `remWord#` y#)
    | otherwise              = divZeroError
  quotRem (W24# x#) y@(W24# y#)
    | y /= 0                 = (W24# (x# `quotWord#` y#), W24# (x# `remWord#` y#))
    | otherwise              = divZeroError
  divMod (W24# x#) y@(W24# y#)
    | y /= 0                 = (W24# (x# `quotWord#` y#), W24# (x# `remWord#` y#))
    | otherwise              = divZeroError
  toInteger (W24# x#)        = smallInteger (word2Int# x#)

instance Bounded Word24 where
  minBound = 0
  maxBound = 0xFFFFFF

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

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

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

    (W24# x#) .&.   (W24# y#)  = W24# (x# `and#` y#)
    (W24# x#) .|.   (W24# y#)  = W24# (x# `or#`  y#)
    (W24# x#) `xor` (W24# y#)  = W24# (x# `xor#` y#)
    complement (W24# x#)       = W24# (x# `xor#` mb#) where !(W24# mb#) = maxBound
    (W24# x#) `shift` (I# i#)
        | isTrue# (i# >=# 0#)  = W24# (narrow24Word# (x# `shiftL#` i#))
        | otherwise            = W24# (x# `shiftRL#` negateInt# i#)
    (W24# x#) `shiftL` (I# i#)       = W24# (narrow24Word# (x# `shiftL#` i#))
    (W24# x#) `unsafeShiftL` (I# i#) =
        W24# (narrow24Word# (x# `uncheckedShiftL#` i#))
    (W24# x#) `shiftR`       (I# i#) = W24# (x# `shiftRL#` i#)
    (W24# x#) `unsafeShiftR` (I# i#) = W24# (x# `uncheckedShiftRL#` i#)
    (W24# x#) `rotate`       i
        | isTrue# (i'# ==# 0#) = W24# x#
        | otherwise  = W24# (narrow24Word# ((x# `uncheckedShiftL#` i'#) `or#`
                                            (x# `uncheckedShiftRL#` (24# -# i'#))))
      where
        !(I# i'#) = i `mod` 24
    bitSizeMaybe i            = Just (finiteBitSize i)
    bitSize                   = finiteBitSize
    isSigned _                = False
    popCount (W24# x#)        = I# (word2Int# (popCnt24# x#))
    bit                       = bitDefault
    testBit                   = testBitDefault

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

-- | Swap bytes in 'Word24'.
--
byteSwap24 :: Word24 -> Word24
byteSwap24 (W24# w#) = W24# (byteSwap24# w#)

byteSwap24# :: Word# -> Word#
byteSwap24# w# = let byte0 = uncheckedShiftL# (and# w# 0x0000ff##) 16#
                     byte1 = and# w# 0x00ff00##
                     byte2 = uncheckedShiftRL# (and# w# 0xff0000##) 16#
                 in byte0 `or#` byte1 `or#` byte2

{-# RULES
"fromIntegral/Word8->Word24"    fromIntegral = \(W8# x#) -> W24# x#
"fromIntegral/Word16->Word24"   fromIntegral = \(W16# x#) -> W24# x#
"fromIntegral/Word24->Word24"   fromIntegral = id :: Word24 -> Word24
"fromIntegral/Word24->Integer"  fromIntegral = toInteger :: Word24 -> Integer
"fromIntegral/a->Word24"        fromIntegral = \x -> case fromIntegral x of W# x# -> W24# (narrow24Word# x#)
"fromIntegral/Word24->a"        fromIntegral = \(W24# x#) -> fromIntegral (W# x#)
  #-}

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

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

readWord24OffPtr :: Ptr Word24 -> IO Word24
readWord24OffPtr p = do
  let p' = castPtr p :: Ptr Word8
  w1 <- peekElemOff p' 0
  w2 <- peekElemOff p' 1
  w3 <- peekElemOff p' 2
  let w1' = (fromIntegral :: (Word8 -> Word24)) w1
      w2' = (fromIntegral :: (Word8 -> Word24)) w2
      w3' = (fromIntegral :: (Word8 -> Word24)) w3
      w = w1' .|. (w2' `shiftL` 8) .|. (w3' `shiftL` 16)
  return w

writeWord24ToPtr :: Ptr Word24 -> Word24 -> IO ()
writeWord24ToPtr p v = do
    let w1 = fromIntegral (v .&. 0x0000FF) :: Word8
        w2 = fromIntegral ((v .&. 0x00FF00) `shiftR` 8) :: Word8
        w3 = fromIntegral ((v .&. 0xFF0000) `shiftR` 16) :: Word8
    pokeByteOff p 0 w1
    pokeByteOff p 1 w2
    pokeByteOff p 2 w3

instance Storable Word24 where
  sizeOf _    = 3
  alignment _ = 3
  peek        = readWord24OffPtr
  poke        = writeWord24ToPtr