Integer.hs

{-# LANGUAGE PatternSynonyms     #-}

-- | PackStream integer type covering the full @[-2^63, 2^64-1]@ range.
module Data.PackStream.Integer
    ( PSInteger
    , ToPSInteger(..)
    , FromPSInteger(..)
    , fromIntegerTry

      -- ** Internal helper
    , tryPSInteger
    ) where

import           Compat.Prelude

import           Control.Exception     (ArithException (DivideByZero, Overflow, Underflow),
                                        throw)
import           Data.Kind             (Constraint, Type)
import           TextShow
import TextShow.Generic
-- import GHC.Generics

import           Compat.Binary
import           Data.PackStream.Tags


-- | Integer type that represents the value range of integral numbers in PackStream; i.e. \( \left[ -2^{63}, 2^{64}-1 \right] \).
-- In other words, `PSInteger` provides the union of the value ranges of `Word64` and `Int64`.
--
-- This type can be unboxed (i.e. via @{-# UNPACK #-}@).
type PSInteger :: Type
data PSInteger = PSInteger {-# UNPACK #-} !Int64
  deriving stock (Eq, Ord, Generic)
  deriving TextShow via FromGeneric (PSInteger)

-- NOTE: Internal invariant of 'PSInteger'
--
-- 'isW64' MUST be true IFF the value range of `Int64` cannot represent the semantic value of 'value'
--
-- Consequently, when 'isW64' is true, 'value :: Int64' must be negative.

-- NB: only valid if isW64 is true
-- toW64 :: Int64 -> Word64
-- toW64 = intCastIso

-- | Types that can be losslessly converted to 'PSInteger'.
type ToPSInteger :: Type -> Constraint
class ToPSInteger a where
  toPSInteger :: a -> PSInteger

instance ToPSInteger Int8  where toPSInteger i = PSInteger (intCast i)
instance ToPSInteger Int16 where toPSInteger i = PSInteger (intCast i)
instance ToPSInteger Int32 where toPSInteger i = PSInteger (intCast i)
instance ToPSInteger Int64 where toPSInteger   = PSInteger 
instance ToPSInteger Int   where toPSInteger i = PSInteger (intCast i)

instance ToPSInteger Word8  where toPSInteger w = PSInteger (intCast w)
instance ToPSInteger Word16 where toPSInteger w = PSInteger (intCast w)
instance ToPSInteger Word32 where toPSInteger w = PSInteger (intCast w)
-- instance ToPSInteger Word64 where toPSInteger w = PSInteger (i<0) i where i = fromIntegral w
-- instance ToPSInteger Word   where toPSInteger w = PSInteger (i<0) i where i = fromIntegral w

-- | Convert a 'PSInteger' value to something else if possible
--
-- The instances for 'FromPSInteger' are supposed to be consistent with the respective instances for 'ToPSInteger', e.g.
--
-- > fromPSInteger . toPSInteger == Just
--
type FromPSInteger :: Type -> Constraint
class FromPSInteger a where
  fromPSInteger :: PSInteger -> Maybe a

-- instance FromPSInteger Word where
--   fromPSInteger (PSInteger w)  = intCastMaybe (toW64 w)
--   fromPSInteger (PSInteger i) = intCastMaybe i

-- instance FromPSInteger Word64 where
--   fromPSInteger (PSInteger w)  = Just $! toW64 w
--   fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Word32 where
  fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Word16 where
  fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Word8 where
  fromPSInteger (PSInteger i) = intCastMaybe i

-----

instance FromPSInteger Int where
  fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Int64 where
  fromPSInteger (PSInteger i) = Just i

instance FromPSInteger Int32 where
  fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Int16 where
  fromPSInteger (PSInteger i) = intCastMaybe i

instance FromPSInteger Int8 where
  fromPSInteger (PSInteger i) = intCastMaybe i

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

instance Bounded PSInteger where
  minBound = PSInteger minBound
  maxBound = PSInteger  (-1) -- this is why we can't autoderive

instance Enum PSInteger where
  toEnum i = PSInteger (toEnum i)
  -- fromEnum (PSInteger i)  = fromEnum (toW64 i)
  fromEnum (PSInteger i) = fromEnum i

instance Show PSInteger where
  showsPrec p (PSInteger v) = showsPrec p v
  -- showsPrec p (PSInteger  v) = showsPrec p (toW64 v)

instance Read PSInteger where
  readsPrec p s = [ (i, rest) | (j, rest) <- readsPrec p s, Right i <- [fromIntegerTry j] ]

instance NFData PSInteger where
  rnf (PSInteger _) = ()

-- | Try to convert 'Integer' into 'PSInteger'
--
-- Will return @'Left' 'Underflow'@ or @'Left' 'Overflow'@ respectively if out of range
fromIntegerTry :: Integer -> Either ArithException PSInteger
fromIntegerTry i
  | i <  toInteger (minBound :: Int64)  = Left Underflow
  | i <= toInteger (maxBound :: Int64)  = Right $! PSInteger (fromInteger i)
  | i <= toInteger (maxBound :: Word64) = Right $! PSInteger (fromInteger i)
  | otherwise = Left Overflow

-- | This instance will throw the respective arithmetic 'Underflow' and 'Overflow' exception if the range of 'PSInteger' is exceeded.
instance Num PSInteger where
  fromInteger i = either throw id (fromIntegerTry i)

  negate (PSInteger v)
    | v == minBound = PSInteger v -- NB: for the usual twos complement integers, `negate minBound == minBound`
    | otherwise     = PSInteger (negate v)
  negate (PSInteger v)
    | v == minBound = PSInteger v
    | otherwise     = throw Underflow

  -- addition
  PSInteger 0 + x = x
  x + PSInteger 0 = x

  PSInteger _  + PSInteger  _ = throw Overflow

  x@(PSInteger _) + y@(PSInteger _) = y + x
  PSInteger y + PSInteger x
    | y > 0     = if z < 0 then PSInteger z else throw Overflow
    | otherwise = PSInteger z
    where
      z = x + y

  PSInteger y + PSInteger x
    | x > 0, y > 0, z < 0 = PSInteger z
    | x < 0, y < 0, z > 0 = throw Underflow
    | otherwise           = PSInteger z
    where
      z = x + y

  signum (PSInteger _)  = PSInteger 1
  signum (PSInteger v) = PSInteger (signum v)

  abs v@(PSInteger _) = v
  abs v0@(PSInteger v)
    | v >= 0 = v0
    | v == minBound = PSInteger  v
    | otherwise     = PSInteger (negate v)


  PSInteger _  * PSInteger _ = throw Overflow
  PSInteger 0  * PSInteger _     = PSInteger 0
  PSInteger 1  * x                 = x
  PSInteger _      * PSInteger 0 = PSInteger 0
  x                  * PSInteger 1 = x

  -- cheat
  x * y = fromInteger (toInteger x * toInteger y)

instance Real PSInteger where
  toRational (PSInteger i) = toRational i
  -- toRational (PSInteger u)  = toRational (toW64 u)

instance Integral PSInteger where
  toInteger (PSInteger i) = toInteger i
  -- toInteger (PSInteger u)  = toInteger (toW64 u)

  quotRem _ (PSInteger 0)    = throw DivideByZero
  quotRem x (PSInteger 1)    = (x, PSInteger 0)
  quotRem x (PSInteger (-1)) = (negate x, PSInteger 0)

  quotRem (PSInteger x) (PSInteger y)
    | (x',y') <- quotRem x y = (PSInteger x', PSInteger y')

  -- cheat
  quotRem x y
    | (x',y') <- quotRem (toInteger x) (toInteger y) = (fromInteger x', fromInteger y')

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

-- | This 'Persist' instance encodes\/decodes to\/from PackStream format
--
-- When serializing 'PSInteger's via 'get' the shortest encoding is
-- used. Moreoever, for non-negative integers the unsigned encoding is
-- always used.
--
-- Deserialization via 'get' will only fail if a non-integer PackStream tag is encountered.
--
instance Persist PSInteger where
  get = getPSInteger
  put = putPSInteger

-- | Serializes 'PSInteger' to PackStream
--
-- The shortest encoding is used to serialize
-- 'PSInteger's. Moreoever, for non-negative integers the unsigned
-- encoding is always used.
putPSInteger :: PSInteger -> Put
putPSInteger (PSInteger i)
  | i >= -16 && i <= 127              = putInt8 (fromIntegral i)
  | i >= -0x80 && i < 0x80           = putWord8 TAG_INT_8  >> putInt8     (fromIntegral i)
  | i >= -0x8000 && i < 0x8000       = putWord8 TAG_INT_16 >> putInt16be  (fromIntegral i)
  | i >= -0x80000000 && i < 0x80000000 = putWord8 TAG_INT_32 >> putInt32be  (fromIntegral i)
  | otherwise                          = putWord8 TAG_INT_64 >> putInt64be                i

-- | Deserializes 'PSInteger' from PackStream
--
-- This operation will only fail if a non-integer PackStream tag is encountered.
getPSInteger :: Get PSInteger
getPSInteger = do { tag <- getWord8; tryPSInteger tag id (fail "expected PackStream int") }

-- | Try to decode a 'PSInteger' given a tag byte, applying @f@ on success or falling through to the continuation.
{-# INLINE tryPSInteger #-}
tryPSInteger :: Word8 -> (PSInteger -> a) -> Get a -> Get a
tryPSInteger tag' f cont = case tag' of
  c | is_TAG_TINY_INT c -> pure $! f $! toPSInteger (intCastIso c :: Int8)
  TAG_INT_8           -> f . toPSInteger <$> getInt8
  TAG_INT_16          -> f . toPSInteger <$> getInt16be
  TAG_INT_32          -> f . toPSInteger <$> getInt32be
  TAG_INT_64          -> f . toPSInteger <$> getInt64be
  _                   -> cont