module Data.Bits.Base(module Data.Bits.Base) where
import qualified Prelude()              -- do not import Prelude
import Primitives
import Control.Error
import Data.Bool
import Data.Eq
import Data.Function
import Data.Int.Int
import Data.Integral
import Data.Maybe
import Data.Ord
import Data.Num
import {-# SOURCE #-} Data.Typeable
import Text.Show

infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.

class Eq a => Bits a where
  (.&.)             :: a -> a -> a
  (.|.)             :: a -> a -> a
  xor               :: a -> a -> a
  complement        :: a -> a
  shift             :: a -> Int -> a
  rotate            :: a -> Int -> a
  zeroBits          :: a
  bit               :: Int -> a
  setBit            :: a -> Int -> a
  clearBit          :: a -> Int -> a
  complementBit     :: a -> Int -> a
  testBit           :: a -> Int -> Bool
  shiftL            :: a -> Int -> a
  unsafeShiftL      :: a -> Int -> a
  shiftR            :: a -> Int -> a
  unsafeShiftR      :: a -> Int -> a
  rotateL           :: a -> Int -> a
  rotateR           :: a -> Int -> a
  popCount          :: a -> Int
  bitSizeMaybe      :: a -> Maybe Int
  bitSize           :: a -> Int
  isSigned          :: a -> Bool

  x `shift`   i | i<0       = x `shiftR` (- i)
                | i>0       = x `shiftL` i
                | otherwise = x


  x `rotate`  i | i<0       = x `rotateR` (- i)
                | i>0       = x `rotateL` i
                | otherwise = x

  {-
  x `rotate`  i | i<0 && isSigned x && x<0
                       = let left = i+bitSize x in
                         ((x `shift` i) .&. complement ((-1) `shift` left))
                         .|. (x `shift` left)
                | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))
                | i==0 = x
                | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))
  -}

  zeroBits            = clearBit (bit 0) 0
  bitSize b           = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b)
  x `setBit` i        = x .|. bit i
  x `clearBit` i      = x .&. complement (bit i)
  x `complementBit` i = x `xor` bit i

  x `shiftL`  i       = x `shift`  i
  x `unsafeShiftL` i  = x `shiftL` i
  x `shiftR`  i       = x `shift`  (- i)
  x `unsafeShiftR` i  = x `shiftR` i

  x `rotateL` i       = x `rotate` i

  x `rotateR` i       = x `rotate` (- i)


class Bits b => FiniteBits b where
  finiteBitSize :: b -> Int
  countLeadingZeros :: b -> Int
  countTrailingZeros :: b -> Int

  countLeadingZeros x = (w - 1) - go (w - 1)
    where
      go i | i < 0       = i -- no bit set
           | testBit x i = i
           | otherwise   = go (i - 1)

      w = finiteBitSize x

  countTrailingZeros x = go 0
    where
      go i | i >= w      = i
           | testBit x i = i
           | otherwise   = go (i + 1)

      w = finiteBitSize x

bitDefault :: (Bits a, Num a) => Int -> a
bitDefault i = 1 `shiftL` i

testBitDefault :: (Bits a, Num a) => a -> Int -> Bool
testBitDefault x i = (x .&. bit i) /= 0

popCountDefault :: (Bits a, Num a) => a -> Int
popCountDefault = go 0
  where
    go c 0 = c
    go c w = go (c + 1) (w .&. (w - 1)) -- clear the least significant bit

_overflowError :: a
_overflowError = error "arithmetic overflow"

instance Bits Int where
  (.&.) = primIntAnd
  (.|.) = primIntOr
  xor   = primIntXor
  complement = primIntInv
  x `shiftL` i
    | i < 0 = _overflowError
    | i >= _wordSize = 0
    | otherwise = x `primIntShl` i
  unsafeShiftL = primIntShl
  x `shiftR` i
    | i < 0 = _overflowError
    | i >= _wordSize = 0
    | otherwise = x `primIntShr` i
  unsafeShiftR = primIntShr
  bitSizeMaybe _ = Just _wordSize
  bitSize _ = _wordSize
  bit = bitDefault
  testBit = testBitDefault
  popCount = primIntPopcount
  zeroBits = 0
  isSigned _ = True

instance FiniteBits Int where
  finiteBitSize _ = _wordSize
  countLeadingZeros = primIntClz
  countTrailingZeros = primIntCtz

toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b
toIntegralSized x
  | maybe True (<= x) yMinBound
  , maybe True (x <=) yMaxBound = Just y
  | otherwise                   = Nothing
  where
    y = fromIntegral x

    xWidth = bitSizeMaybe x
    yWidth = bitSizeMaybe y

    yMinBound
      | isBitSubType x y = Nothing
      | isSigned x, not (isSigned y) = Just 0
      | isSigned x, isSigned y
      , Just yW <- yWidth = Just (negate $ bit (yW-1))
      | otherwise = Nothing

    yMaxBound
      | isBitSubType x y = Nothing
      | isSigned x, not (isSigned y)
      , Just xW <- xWidth, Just yW <- yWidth
      , xW <= yW+1 = Nothing
      | Just yW <- yWidth = if isSigned y
                            then Just (bit (yW-1)-1)
                            else Just (bit yW-1)
      | otherwise = Nothing

isBitSubType :: (Bits a, Bits b) => a -> b -> Bool
isBitSubType x y
  -- Reflexive
  | xWidth == yWidth, xSigned == ySigned = True

  -- Every integer is a subset of 'Integer'
  | ySigned, isNothing yWidth                  = True
  | not xSigned, not ySigned, isNothing yWidth = True

  -- Sub-type relations between fixed-with types
  | xSigned == ySigned,   Just xW <- xWidth, Just yW <- yWidth = xW <= yW
  | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <  yW

  | otherwise = False
  where
    xWidth  = bitSizeMaybe x
    xSigned = isSigned     x

    yWidth  = bitSizeMaybe y
    ySigned = isSigned     y