{-|
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
  { Overflowing a -> a
fromOverflowing :: a
    -- ^ Retrieve the value
  , Overflowing a -> Bool
hasOverflowed :: Bool
    -- ^ 'True' when a computation has overflowed
  }
  deriving stock ((forall x. Overflowing a -> Rep (Overflowing a) x)
-> (forall x. Rep (Overflowing a) x -> Overflowing a)
-> Generic (Overflowing a)
forall x. Rep (Overflowing a) x -> Overflowing a
forall x. Overflowing a -> Rep (Overflowing a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Overflowing a) x -> Overflowing a
forall a x. Overflowing a -> Rep (Overflowing a) x
$cto :: forall a x. Rep (Overflowing a) x -> Overflowing a
$cfrom :: forall a x. Overflowing a -> Rep (Overflowing a) x
Generic, Int -> Overflowing a -> ShowS
[Overflowing a] -> ShowS
Overflowing a -> String
(Int -> Overflowing a -> ShowS)
-> (Overflowing a -> String)
-> ([Overflowing a] -> ShowS)
-> Show (Overflowing a)
forall a. Show a => Int -> Overflowing a -> ShowS
forall a. Show a => [Overflowing a] -> ShowS
forall a. Show a => Overflowing a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Overflowing a] -> ShowS
$cshowList :: forall a. Show a => [Overflowing a] -> ShowS
show :: Overflowing a -> String
$cshow :: forall a. Show a => Overflowing a -> String
showsPrec :: Int -> Overflowing a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Overflowing a -> ShowS
Show)
  deriving anyclass (Get (Overflowing a)
[Overflowing a] -> Put
Overflowing a -> Put
(Overflowing a -> Put)
-> Get (Overflowing a)
-> ([Overflowing a] -> Put)
-> Binary (Overflowing a)
forall a. Binary a => Get (Overflowing a)
forall a. Binary a => [Overflowing a] -> Put
forall a. Binary a => Overflowing a -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Overflowing a] -> Put
$cputList :: forall a. Binary a => [Overflowing a] -> Put
get :: Get (Overflowing a)
$cget :: forall a. Binary a => Get (Overflowing a)
put :: Overflowing a -> Put
$cput :: forall a. Binary a => Overflowing a -> Put
Binary, Eq (Overflowing a)
Eq (Overflowing a)
-> (Int -> Overflowing a -> Int)
-> (Overflowing a -> Int)
-> Hashable (Overflowing a)
Int -> Overflowing a -> Int
Overflowing a -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (Overflowing a)
forall a. Hashable a => Int -> Overflowing a -> Int
forall a. Hashable a => Overflowing a -> Int
hash :: Overflowing a -> Int
$chash :: forall a. Hashable a => Overflowing a -> Int
hashWithSalt :: Int -> Overflowing a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> Overflowing a -> Int
$cp1Hashable :: forall a. Hashable a => Eq (Overflowing a)
Hashable, Overflowing a -> ()
(Overflowing a -> ()) -> NFData (Overflowing a)
forall a. NFData a => Overflowing a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Overflowing a -> ()
$crnf :: forall a. NFData a => Overflowing a -> ()
NFData, HasCallStack => String -> Overflowing a
Overflowing a -> Bool
Overflowing a -> ()
Overflowing a -> Overflowing a
(HasCallStack => String -> Overflowing a)
-> (Overflowing a -> Bool)
-> (Overflowing a -> Overflowing a)
-> (Overflowing a -> ())
-> NFDataX (Overflowing a)
forall a. (NFDataX a, HasCallStack) => String -> Overflowing a
forall a. NFDataX a => Overflowing a -> Bool
forall a. NFDataX a => Overflowing a -> ()
forall a. NFDataX a => Overflowing a -> Overflowing a
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
rnfX :: Overflowing a -> ()
$crnfX :: forall a. NFDataX a => Overflowing a -> ()
ensureSpine :: Overflowing a -> Overflowing a
$censureSpine :: forall a. NFDataX a => Overflowing a -> Overflowing a
hasUndefined :: Overflowing a -> Bool
$chasUndefined :: forall a. NFDataX a => Overflowing a -> Bool
deepErrorX :: String -> Overflowing a
$cdeepErrorX :: forall a. (NFDataX a, HasCallStack) => String -> Overflowing a
NFDataX, Int -> Overflowing a -> ShowS
[Overflowing a] -> ShowS
Overflowing a -> String
(Int -> Overflowing a -> ShowS)
-> (Overflowing a -> String)
-> ([Overflowing a] -> ShowS)
-> ShowX (Overflowing a)
forall a. ShowX a => Int -> Overflowing a -> ShowS
forall a. ShowX a => [Overflowing a] -> ShowS
forall a. ShowX a => Overflowing a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowX a
showListX :: [Overflowing a] -> ShowS
$cshowListX :: forall a. ShowX a => [Overflowing a] -> ShowS
showX :: Overflowing a -> String
$cshowX :: forall a. ShowX a => Overflowing a -> String
showsPrecX :: Int -> Overflowing a -> ShowS
$cshowsPrecX :: forall a. ShowX a => Int -> Overflowing a -> ShowS
ShowX)

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

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

instance (Eq a) => Eq (Overflowing a) where
  {-# INLINE (==) #-}
  == :: Overflowing a -> Overflowing a -> Bool
(==) = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Overflowing a -> a) -> Overflowing a -> Overflowing a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

instance (Ord a) => Ord (Overflowing a) where
  {-# INLINE compare #-}
  compare :: Overflowing a -> Overflowing a -> Ordering
compare = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering)
-> (Overflowing a -> a)
-> Overflowing a
-> Overflowing a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Overflowing a -> a
forall a. Overflowing a -> a
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 :: Overflowing a -> Bool
even = a -> Bool
forall a. Parity a => a -> Bool
even (a -> Bool) -> (Overflowing a -> a) -> Overflowing a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

  {-# INLINE odd #-}
  odd :: Overflowing a -> Bool
odd = a -> Bool
forall a. Parity a => a -> Bool
odd (a -> Bool) -> (Overflowing a -> a) -> Overflowing a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

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

    | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
    , a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap a
forall a. Bounded a => a
minBound a
y
    = Bool -> Overflowing a
withOverflow Bool
True

    | Bool
otherwise
    = Bool -> Overflowing a
withOverflow (Bool
a Bool -> Bool -> Bool
|| Bool
b)
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap a
x a
y)

  Overflowing a
x Bool
a - :: Overflowing a -> Overflowing a -> Overflowing a
- Overflowing a
y Bool
b
    | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
    , a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap a
forall a. Bounded a => a
maxBound a
y
    = Bool -> Overflowing a
withOverflow Bool
True

    | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0
    , a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satAdd SaturationMode
SatWrap a
forall a. Bounded a => a
minBound a
y
    = Bool -> Overflowing a
withOverflow Bool
True

    | Bool
otherwise
    = Bool -> Overflowing a
withOverflow (Bool
a Bool -> Bool -> Bool
|| Bool
b)
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satSub SaturationMode
SatWrap a
x a
y)

  Overflowing a
x Bool
a * :: Overflowing a -> Overflowing a -> Overflowing a
* Overflowing a
y Bool
b
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
    , a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
    , SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satMul SaturationMode
SatZero a
x a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
    = Bool -> Overflowing a
withOverflow Bool
True

    | Bool
otherwise
    = Bool -> Overflowing a
withOverflow (Bool
a Bool -> Bool -> Bool
|| Bool
b)
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (SaturationMode -> a -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a -> a
satMul SaturationMode
SatWrap a
x a
y)

  negate :: Overflowing a -> Overflowing a
negate n :: Overflowing a
n@(Overflowing a
x Bool
a)
    | a
0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x = Overflowing a
n
    | a
0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= Bounded a => a
forall a. Bounded a => a
minBound @a = Bool -> Overflowing a
withOverflow Bool
True
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound = Bool -> Overflowing a
withOverflow Bool
True
    | Bool
otherwise = Bool -> Overflowing a
withOverflow Bool
a
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (a -> a
forall a. Num a => a -> a
negate a
x)

  abs :: Overflowing a -> Overflowing a
abs (Overflowing a
x Bool
a)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
x Bool
True
    | Bool
otherwise = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (a -> a
forall a. Num a => a -> a
abs a
x) Bool
a

  signum :: Overflowing a -> Overflowing a
signum (Overflowing a
x Bool
a) =
    a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (a -> a
forall a. Num a => a -> a
signum a
x) Bool
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 :: Integer -> Overflowing a
fromInteger Integer
i =
    a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i) Bool
False

instance (Bounded a) => Bounded (Overflowing a) where
  minBound :: Overflowing a
minBound = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
forall a. Bounded a => a
minBound Bool
False
  maxBound :: Overflowing a
maxBound = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
forall a. Bounded a => a
maxBound Bool
False

instance (Enum a, Eq a, SaturatingNum a) => Enum (Overflowing a) where
  succ :: Overflowing a -> Overflowing a
succ (Overflowing a
x Bool
a)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
maxBound = Bool -> Overflowing a
withOverflow Bool
True
    | Bool
otherwise = Bool -> Overflowing a
withOverflow Bool
a
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (SaturationMode -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a
satSucc SaturationMode
SatWrap a
x)

  pred :: Overflowing a -> Overflowing a
pred (Overflowing a
x Bool
a)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound = Bool -> Overflowing a
withOverflow Bool
True
    | Bool
otherwise = Bool -> Overflowing a
withOverflow Bool
a
   where
    withOverflow :: Bool -> Overflowing a
withOverflow = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (SaturationMode -> a -> a
forall a. SaturatingNum a => SaturationMode -> a -> a
satPred SaturationMode
SatWrap a
x)

  toEnum :: Int -> Overflowing a
toEnum Int
i = a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (Int -> a
forall a. Enum a => Int -> a
toEnum Int
i) Bool
False
  fromEnum :: Overflowing a -> Int
fromEnum = a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> Int) -> (Overflowing a -> a) -> Overflowing a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

instance (Real a, SaturatingNum a) => Real (Overflowing a) where
  toRational :: Overflowing a -> Rational
toRational = a -> Rational
forall a. Real a => a -> Rational
toRational (a -> Rational)
-> (Overflowing a -> a) -> Overflowing a -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

instance (Integral a, SaturatingNum a) => Integral (Overflowing a) where
  quotRem :: Overflowing a -> Overflowing a -> (Overflowing a, Overflowing a)
quotRem (Overflowing a
x Bool
a) (Overflowing a
y Bool
b)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 =
        Bool -> (Overflowing a, Overflowing a)
withOverflow Bool
True

    | Bool
otherwise =
        Bool -> (Overflowing a, Overflowing a)
withOverflow (Bool
a Bool -> Bool -> Bool
|| Bool
b)
   where
    withOverflow :: Bool -> (Overflowing a, Overflowing a)
withOverflow Bool
o =
      let (a
q, a
r) = a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
quotRem a
x a
y
       in (a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
q Bool
o, a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
r Bool
False)

  divMod :: Overflowing a -> Overflowing a -> (Overflowing a, Overflowing a)
divMod (Overflowing a
x Bool
a) (Overflowing a
y Bool
b)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 =
        Bool -> (Overflowing a, Overflowing a)
withOverflow Bool
True

    | Bool
otherwise =
        Bool -> (Overflowing a, Overflowing a)
withOverflow (Bool
a Bool -> Bool -> Bool
|| Bool
b)
   where
    withOverflow :: Bool -> (Overflowing a, Overflowing a)
withOverflow Bool
o =
      let (a
d, a
m) = a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
divMod a
x a
y
       in (a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
d Bool
o, a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
m Bool
False)

  toInteger :: Overflowing a -> Integer
toInteger = a -> Integer
forall a. Integral a => a -> Integer
toInteger (a -> Integer) -> (Overflowing a -> a) -> Overflowing a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing

instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Overflowing a) where
  recip :: Overflowing a -> Overflowing a
recip Overflowing a
x =
    Overflowing a
x { fromOverflowing :: a
fromOverflowing = a -> a
forall a. Fractional a => a -> a
recip (Overflowing a -> a
forall a. Overflowing a -> a
fromOverflowing Overflowing a
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 :: Rational -> Overflowing a
fromRational Rational
i =
    a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing (Rational -> a
forall a. Fractional a => Rational -> a
fromRational Rational
i) Bool
False

instance (RealFrac a, SaturatingNum a) => RealFrac (Overflowing a) where
  properFraction :: Overflowing a -> (b, Overflowing a)
properFraction (Overflowing a
x Bool
_) =
    let (b
n, a
f) = a -> (b, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
x
     in (b
n, a -> Bool -> Overflowing a
forall a. a -> Bool -> Overflowing a
Overflowing a
f Bool
False)