Overflowing.hs

{-|
Copyright  :  (C) 2021-2022, QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Clash.Num.Overflowing
  ( Overflowing
  , fromOverflowing
  , hasOverflowed
  , toOverflowing
  , clearOverflow
  ) where

import Prelude hiding (even, odd)

import Control.DeepSeq (NFData)
import Data.Binary (Binary)
import Data.Function (on)
import Data.Hashable (Hashable)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat, type (+))

import Clash.Class.BitPack (BitPack(..))
import Clash.Class.Num (SaturationMode(SatWrap, SatZero), SaturatingNum(..))
import Clash.Class.Parity (Parity(..))
import Clash.XException (NFDataX, ShowX)

-- | An overflowing number behaves similarly to a 'Clash.Num.Wrapping.Wrapping'
-- number, but also includes an overflow status flag which can be used to more
-- easily check if an overflow has occurred.
--
-- Numbers can be converted to be 'Overflowing' using 'toOverflowing'.
--
data Overflowing a = Overflowing
  { fromOverflowing :: a
    -- ^ Retrieve the value
  , hasOverflowed :: Bool
    -- ^ 'True' when a computation has overflowed
  }
  deriving stock (Generic, Show)
  deriving anyclass (Binary, Hashable, NFData, NFDataX, ShowX)

{-# INLINE toOverflowing #-}
toOverflowing :: a -> Overflowing a
toOverflowing x = Overflowing x False

{-# INLINE clearOverflow #-}
-- | Reset the overflow status flag to False.
clearOverflow :: Overflowing a -> Overflowing a
clearOverflow x = x { hasOverflowed = False }

instance (Eq a) => Eq (Overflowing a) where
  {-# INLINE (==) #-}
  (==) = (==) `on` fromOverflowing

instance (Ord a) => Ord (Overflowing a) where
  {-# INLINE compare #-}
  compare = compare `on` fromOverflowing

instance (BitPack a, KnownNat (BitSize a + 1)) => BitPack (Overflowing a) where
  type BitSize (Overflowing a) = BitSize a + 1
  -- Default instance, no explicit implementations.

instance (Parity a) => Parity (Overflowing a) where
  {-# INLINE even #-}
  even = even . fromOverflowing

  {-# INLINE odd #-}
  odd = odd . fromOverflowing

instance (Bounded a, Ord a, SaturatingNum a) => Num (Overflowing a) where
  Overflowing x a + Overflowing y b
    | y > 0
    , x > satSub SatWrap maxBound y
    = withOverflow True

    | y < 0
    , x < satSub SatWrap minBound y
    = withOverflow True

    | otherwise
    = withOverflow (a || b)
   where
    withOverflow = Overflowing (satAdd SatWrap x y)

  Overflowing x a - Overflowing y b
    | y < 0
    , x > satAdd SatWrap maxBound y
    = withOverflow True

    | y > 0
    , x < satAdd SatWrap minBound y
    = withOverflow True

    | otherwise
    = withOverflow (a || b)
   where
    withOverflow = Overflowing (satSub SatWrap x y)

  Overflowing x a * Overflowing y b
    | x /= 0
    , y /= 0
    , satMul SatZero x y == 0
    = withOverflow True

    | otherwise
    = withOverflow (a || b)
   where
    withOverflow = Overflowing (satMul SatWrap x y)

  negate n@(Overflowing x a)
    | 0 == x = n
    | 0 <= minBound @a = withOverflow True
    | x == minBound = withOverflow True
    | otherwise = withOverflow a
   where
    withOverflow = Overflowing (negate x)

  abs (Overflowing x a)
    | x == minBound && x < 0 = Overflowing x True
    | otherwise = Overflowing (abs x) a

  signum (Overflowing x a) =
    Overflowing (signum x) a

  -- TODO This does what the underlying representation does if the Integer
  -- is not in range (typically wrapping). It would be better if this also
  -- definitely wrapped, but in a way which remained synthesizable.
  fromInteger i =
    Overflowing (fromInteger i) False

instance (Bounded a) => Bounded (Overflowing a) where
  minBound = Overflowing minBound False
  maxBound = Overflowing maxBound False

instance (Enum a, Eq a, SaturatingNum a) => Enum (Overflowing a) where
  succ (Overflowing x a)
    | x == maxBound = withOverflow True
    | otherwise = withOverflow a
   where
    withOverflow = Overflowing (satSucc SatWrap x)

  pred (Overflowing x a)
    | x == minBound = withOverflow True
    | otherwise = withOverflow a
   where
    withOverflow = Overflowing (satPred SatWrap x)

  toEnum i = Overflowing (toEnum i) False
  fromEnum = fromEnum . fromOverflowing

instance (Real a, SaturatingNum a) => Real (Overflowing a) where
  toRational = toRational . fromOverflowing

instance (Integral a, SaturatingNum a) => Integral (Overflowing a) where
  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types
  quotRem (Overflowing x a) (Overflowing y b)
    | x == minBound && y < 0 && y == -1 =
        withOverflow True

    | otherwise =
        withOverflow (a || b)
   where
    withOverflow o =
      let (q, r) = quotRem x y
       in (Overflowing q o, Overflowing r False)

  divMod (Overflowing x a) (Overflowing y b)
    | x == minBound && y < 0 && y == -1 =
        withOverflow True

    | otherwise =
        withOverflow (a || b)
   where
    withOverflow o =
      let (d, m) = divMod x y
       in (Overflowing d o, Overflowing m False)

  toInteger = toInteger . fromOverflowing

instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Overflowing a) where
  recip x =
    x { fromOverflowing = recip (fromOverflowing x) }

  -- TODO This does what the underlying representation does if the Rational
  -- is not in range (typically wrapping). It would be better if this also
  -- definitely wrapped, but in a way which remained synthesizable.
  fromRational i =
    Overflowing (fromRational i) False

instance (RealFrac a, SaturatingNum a) => RealFrac (Overflowing a) where
  properFraction (Overflowing x _) =
    let (n, f) = properFraction x
     in (n, Overflowing f False)