Erroring.hs

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

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Clash.Num.Erroring
  ( Erroring
  , fromErroring  -- exported here because haddock https://github.com/haskell/haddock/issues/456
  , toErroring
  ) where

import Control.DeepSeq (NFData)
import Data.Binary (Binary)
import Data.Bits (Bits, FiniteBits)
import Data.Coerce (coerce)
import Data.Functor.Compose (Compose(..))
import Data.Hashable (Hashable)
import GHC.TypeLits (KnownNat, type (+))
import Test.QuickCheck (Arbitrary)

import Clash.Class.BitPack (BitPack)
import Clash.Class.Num (SaturationMode(SatError), SaturatingNum(..))
import Clash.Class.Parity (Parity)
import Clash.Class.Resize (Resize(..))
import Clash.XException (NFDataX, ShowX, errorX)

-- | An erroring number type is one where all operations return a
-- 'Clash.XException.XExecption' if they would go out of bounds for the
-- underlying type.
--
-- Numbers can be converted to error by default using 'toErroring'.
--
newtype Erroring a =
  Erroring { fromErroring :: a }
  deriving newtype
    ( Arbitrary
    , Binary
    , Bits
    , BitPack
    , Bounded
    , Eq
    , FiniteBits
    , Hashable
    , NFData
    , NFDataX
    , Ord
    , Parity
    , Show
    , ShowX
    )

{-# INLINE toErroring #-}
toErroring :: (SaturatingNum a) => a -> Erroring a
toErroring = Erroring

instance (Resize f) => Resize (Compose Erroring f) where
  {-# INLINE resize #-}
  resize
    :: forall a b
     . (KnownNat a, KnownNat b)
    => Compose Erroring f a
    -> Compose Erroring f b
  resize = coerce (resize @f @a @b)

  {-# INLINE zeroExtend #-}
  zeroExtend
    :: forall a b
     . (KnownNat a, KnownNat b)
    => Compose Erroring f a
    -> Compose Erroring f (b + a)
  zeroExtend = coerce (zeroExtend @f @a @b)

  {-# INLINE truncateB #-}
  truncateB
    :: forall a b
     . (KnownNat a)
    => Compose Erroring f (a + b)
    -> Compose Erroring f a
  truncateB = coerce (truncateB @f @a @b)

instance (Bounded a, Ord a, SaturatingNum a) => Num (Erroring a) where
  {-# INLINE (+) #-}
  (+) = coerce (satAdd @a SatError)

  {-# INLINE (-) #-}
  (-) = coerce (satSub @a SatError)

  {-# INLINE (*) #-}
  (*) = coerce (satMul @a SatError)

  negate x
    | 0 == x = x
    | 0 <= minBound @a = errorX "Erroring.negate: result exceeds minBound"
    | x == minBound = errorX "Erroring.negate: result exceeds maxBound"
    | otherwise = coerce (negate @a) x

  abs x
    | x == minBound && x < 0 = errorX "Erroring.abs: result exceeds maxBound"
    | otherwise = coerce (abs @a) x

  {-# INLINE signum #-}
  signum = coerce (signum @a)

  {-# INLINE fromInteger #-}
  -- TODO This does what the underlying representation does if the Integer
  -- is not in range (typically wrapping). It would be better if this also
  -- threw an XException, but in a way which remained synthesizable.
  fromInteger = coerce (fromInteger @a)

instance (Enum a, SaturatingNum a) => Enum (Erroring a) where
  {-# INLINE succ #-}
  succ = coerce (satSucc @a SatError)

  {-# INLINE pred #-}
  pred = coerce (satPred @a SatError)

  {-# INLINE toEnum #-}
  toEnum = coerce (toEnum @a)

  {-# INLINE fromEnum #-}
  fromEnum = coerce (fromEnum @a)

instance (Real a, SaturatingNum a) => Real (Erroring a) where
  {-# INLINE toRational #-}
  toRational = coerce (toRational @a)

instance (Integral a, SaturatingNum a) => Integral (Erroring a) where
  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types
  quotRem x y
    | x == minBound && y < 0 && y == -1 =
        (errorX "Erroring.quotRem: result exceeds maxBound", 0)
    | otherwise = coerce (quotRem @a) x y

  divMod x y
    | x == minBound && y < 0 && y == -1 =
        (errorX "Erroring.divMod: result exceeds maxBound", 0)
    | otherwise = coerce (divMod @a) x y

  {-# INLINE toInteger #-}
  toInteger = coerce (toInteger @a)

instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Erroring a) where
  {-# INLINE recip #-}
  recip = coerce (recip @a)

  {-# INLINE fromRational #-}
  -- TODO This does what the underlying representation does if the Rational
  -- is not in range (typically wrapping). It would be better if this also
  -- threw an XException, but in a way which remained synthesizable.
  fromRational = coerce (fromRational @a)

instance (RealFrac a, SaturatingNum a) => RealFrac (Erroring a) where
  {-# INLINE properFraction #-}
  properFraction :: forall b. (Integral b) => Erroring a -> (b, Erroring a)
  properFraction = coerce (properFraction @a @b)