{-# 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
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

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

-- 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#
#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