{-|
Copyright  :  (C) 2013-2016, University of Twente,
                  2016     , Myrtle Software Ltd,
                  2021-2024, QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE Unsafe #-}

{-# OPTIONS_HADDOCK show-extensions not-home #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Clash.Sized.Internal.Signed
  ( -- * Datatypes
    Signed (..)
    -- * Accessors
    -- ** Length information
  , size#
    -- * Type classes
    -- ** BitPack
  , pack#
  , unpack#
    -- ** Eq
  , eq#
  , neq#
    -- ** Ord
  , lt#
  , ge#
  , gt#
  , le#
    -- ** Enum
  , toEnum#
  , fromEnum#
    -- ** Enum (not synthesizable)
  , enumFrom#
  , enumFromThen#
  , enumFromTo#
  , enumFromThenTo#
    -- ** Bounded
  , minBound#
  , maxBound#
    -- ** Num
  , (+#)
  , (-#)
  , (*#)
  , negate#
  , abs#
  , fromInteger#
    -- ** ExtendingNum
  , plus#
  , minus#
  , times#
    -- ** Integral
  , quot#
  , rem#
  , div#
  , mod#
  , toInteger#
    -- ** Bits
  , and#
  , or#
  , xor#
  , complement#
  , shiftL#
  , shiftR#
  , rotateL#
  , rotateR#
    -- ** Resize
  , resize#
  , truncateB#
    -- ** SaturatingNum
  , minBoundSym#
  )
where

import Prelude hiding                 (odd, even)

import Control.DeepSeq                (NFData (..))
import Control.Lens                   (Index, Ixed (..), IxValue)
import Data.Bits                      (Bits (..), FiniteBits (..))
import Data.Data                      (Data)
import Data.Default.Class             (Default (..))
import Data.Proxy                     (Proxy (..))
import Text.Read                      (Read (..), ReadPrec)
import Text.Printf                    (PrintfArg (..), printf)
import GHC.Generics                   (Generic)
import GHC.Natural                    (naturalFromInteger, naturalToInteger)

import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal)
import GHC.TypeLits.Extra             (Max)
import Data.Ix                        (Ix(..))
import Language.Haskell.TH            (appT, conT, litT, numTyLit, sigE)
import Language.Haskell.TH.Syntax     (Lift(..))
#if MIN_VERSION_template_haskell(2,16,0)
import Language.Haskell.TH.Compat
#endif
#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH            (Quote, Type)
#else
import Language.Haskell.TH            (TypeQ)
#endif
import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),
                                       arbitraryBoundedIntegral,
                                       coarbitraryIntegral, shrinkIntegral)

import Clash.Annotations.Primitive (hasBlackBox)
import Clash.Class.BitPack            (BitPack (..), packXWith)
import Clash.Class.Num                (ExtendingNum (..), SaturatingNum (..),
                                       SaturationMode (..))
import Clash.Class.Parity             (Parity (..))
import Clash.Class.Resize             (Resize (..))
import Clash.Class.BitPack.BitIndex   ((!), msb, replaceBit, split)
import Clash.Class.BitPack.BitReduction (reduceAnd, reduceOr)
import Clash.Promoted.Nat             (natToNatural)
import Clash.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low, undefError)
import qualified Clash.Sized.Internal.BitVector as BV
import Clash.XException
  (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX)

{- $setup
>>> :m -Prelude
>>> import Clash.Prelude
-}

type role Signed nominal

-- | Arbitrary-width signed integer represented by @n@ bits, including the sign
-- bit
--
-- Uses standard 2-complements representation. Meaning that, given @n@ bits,
-- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1] for
-- @n > 0@. When @n = 0@, both the min and max bound are 0.
--
-- * __NB__: The usual Haskell method of converting an integral numeric type to
-- another, 'fromIntegral', is not well suited for Clash as it will go through
-- 'Integer' which is arbitrarily bounded in HDL. Instead use
-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.
-- * __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want
-- saturation on overflow, check out the 'SaturatingNum' class.
--
-- >>>  maxBound :: Signed 3
-- 3
-- >>> minBound :: Signed 3
-- -4
-- >>> read (show (minBound :: Signed 3)) :: Signed 3
-- -4
-- >>> 1 + 2 :: Signed 3
-- 3
-- >>> 2 + 3 :: Signed 3
-- -3
-- >>> (-2) + (-3) :: Signed 3
-- 3
-- >>> 2 * 3 :: Signed 4
-- 6
-- >>> 2 * 4 :: Signed 4
-- -8
-- >>> (2 :: Signed 3) `mul` (4 :: Signed 4) :: Signed 7
-- 8
-- >>> (2 :: Signed 3) `add` (3 :: Signed 3) :: Signed 4
-- 5
-- >>> (-2 :: Signed 3) `add` (-3 :: Signed 3) :: Signed 4
-- -5
-- >>> satAdd SatSymmetric 2 3 :: Signed 3
-- 3
-- >>> satAdd SatSymmetric (-2) (-3) :: Signed 3
-- -3
--
-- Signed has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>
--
-- >>> :i Signed
-- type role Signed nominal
-- ...
--
-- as it is not safe to coerce between different width Signed. To change the
-- width, use the functions in the 'Clash.Class.Resize.Resize' class.
#if MIN_VERSION_base(4,15,0) && !MIN_VERSION_base(4,17,0)
data Signed (n :: Nat) =
    -- | The constructor, 'S', and the field, 'unsafeToInteger', are not
    -- synthesizable.
    S { unsafeToInteger :: !Integer}
#else
newtype Signed (n :: Nat) =
    -- | The constructor, 'S', and the field, 'unsafeToInteger', are not
    -- synthesizable.
    S { unsafeToInteger :: Integer}
#endif
  deriving (Data, Generic)

{-# ANN S hasBlackBox #-}

instance NFDataX (Signed n) where
  deepErrorX = errorX
  rnfX = rwhnfX

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE size# #-}
{-# ANN size# hasBlackBox #-}
size# :: KnownNat n => Signed n -> Int
size# bv = fromInteger (natVal bv)

instance NFData (Signed n) where
  rnf (S i) = rnf i `seq` ()
  {-# NOINLINE rnf #-}
  -- NOINLINE is needed so that Clash doesn't trip on the "Signed ~# Integer"
  -- coercion

instance Show (Signed n) where
  show (S i) = show i
  {-# NOINLINE show #-}

instance ShowX (Signed n) where
  showsPrecX = showsPrecXWith showsPrec

-- | None of the 'Read' class' methods are synthesizable.
instance KnownNat n => Read (Signed n) where
  readPrec = fromIntegral <$> (readPrec :: ReadPrec Integer)

instance KnownNat n => BitPack (Signed n) where
  type BitSize (Signed n) = n
  pack   = packXWith pack#
  unpack = unpack#

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE pack# #-}
{-# ANN pack# hasBlackBox #-}
pack# :: forall n . KnownNat n => Signed n -> BitVector n
pack# (S i) = let m = 1 `shiftL0` fromInteger (natVal (Proxy @n))
              in  if i < 0 then BV 0 (naturalFromInteger (m + i)) else BV 0 (naturalFromInteger i)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE unpack# #-}
{-# ANN unpack# hasBlackBox #-}
unpack# :: forall n . KnownNat n => BitVector n -> Signed n
unpack# (BV 0 i) =
  let m = 1 `shiftL0` fromInteger (natVal (Proxy @n) - 1)
      n = naturalToInteger i
  in  if n >= m then S (n-2*m) else S n
unpack# bv = undefError "Signed.unpack" [bv]

instance Eq (Signed n) where
  (==) = eq#
  (/=) = neq#

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE eq# #-}
{-# ANN eq# hasBlackBox #-}
eq# :: Signed n -> Signed n -> Bool
eq# (S v1) (S v2) = v1 == v2

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE neq# #-}
{-# ANN neq# hasBlackBox #-}
neq# :: Signed n -> Signed n -> Bool
neq# (S v1) (S v2) = v1 /= v2

instance Ord (Signed n) where
  (<)  = lt#
  (>=) = ge#
  (>)  = gt#
  (<=) = le#

lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE lt# #-}
{-# ANN lt# hasBlackBox #-}
lt# (S n) (S m) = n < m
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE ge# #-}
{-# ANN ge# hasBlackBox #-}
ge# (S n) (S m) = n >= m
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE gt# #-}
{-# ANN gt# hasBlackBox #-}
gt# (S n) (S m) = n > m
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE le# #-}
{-# ANN le# hasBlackBox #-}
le# (S n) (S m) = n <= m

-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and
-- 'enumFromThenTo', are not synthesizable.
instance KnownNat n => Enum (Signed n) where
  succ n
    | n == maxBound =
        error $ "'succ' was called on (" <> show @(Signed n) maxBound <> " :: "
             <> "Signed " <> show (natToNatural @n) <> ") and caused an "
             <> "overflow. Use 'satSucc' and specify a SaturationMode if you "
             <> "need other behavior."
    | otherwise = n +# fromInteger# 1

  pred n
    | n == minBound =
        error $ "'pred' was called on (" <> show @(Signed n) maxBound <> " :: "
             <> "Signed " <> show (natToNatural @n) <> ") and caused an "
             <> "underflow. Use 'satPred' and specify a SaturationMode if you "
             <> "need other behavior."
    | otherwise = n -# fromInteger# 1

  toEnum         = toEnum#
  fromEnum       = fromEnum#
  enumFrom       = enumFrom#
  enumFromThen   = enumFromThen#
  enumFromTo     = enumFromTo#
  enumFromThenTo = enumFromThenTo#

toEnum# :: forall n. KnownNat n => Int -> Signed n
toEnum# = fromInteger# . toInteger
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE toEnum# #-}
{-# ANN toEnum# hasBlackBox #-}

fromEnum# :: forall n. KnownNat n => Signed n -> Int
fromEnum# = fromEnum . toInteger#
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE fromEnum# #-}
{-# ANN fromEnum# hasBlackBox #-}

enumFrom# :: forall n. KnownNat n => Signed n -> [Signed n]
enumFrom# x = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x .. unsafeToInteger (maxBound :: Signed n)]
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE enumFrom# #-}

enumFromThen# :: forall n. KnownNat n => Signed n -> Signed n -> [Signed n]
enumFromThen# x y =
  toSigneds [unsafeToInteger x, unsafeToInteger y .. unsafeToInteger bound]
 where
  bound = if x <= y then maxBound else minBound :: Signed n
  toSigneds = map (fromInteger_INLINE sz mB mask)
  sz = fromInteger (natVal (Proxy @n)) - 1
  mB = 1 `shiftL` sz
  mask = mB - 1
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE enumFromThen# #-}

enumFromTo# :: forall n. KnownNat n => Signed n -> Signed n -> [Signed n]
enumFromTo# x y = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x .. unsafeToInteger y]
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE enumFromTo# #-}

enumFromThenTo# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n -> [Signed n]
enumFromThenTo# x1 x2 y = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE enumFromThenTo# #-}


instance KnownNat n => Bounded (Signed n) where
  minBound = minBound#
  maxBound = maxBound#

minBound# :: forall n. KnownNat n => Signed n
minBound# =
  case natToNatural @n of
    0 -> 0
    n -> S (negate $ 2 ^ (n - 1))
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE minBound# #-}
{-# ANN minBound# hasBlackBox #-}

maxBound# :: forall n. KnownNat n => Signed n
maxBound# =
  case natToNatural @n of
    0 -> 0
    n -> S (2 ^ (n - 1) - 1)
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE maxBound# #-}
{-# ANN maxBound# hasBlackBox #-}

-- | Operators do @wrap-around@ on overflow
--
-- __NB__: 'fromInteger'/'fromIntegral' can cause unexpected truncation, as
-- 'Integer' is arbitrarily bounded during synthesis.  Prefer
-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.
instance KnownNat n => Num (Signed n) where
  (+)         = (+#)
  (-)         = (-#)
  (*)         = (*#)
  negate      = negate#
  abs         = abs#
  signum s    = if s < 0 then (-1) else
                   if s > 0 then 1 else 0
  fromInteger = fromInteger#

(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE (+#) #-}
{-# ANN (+#) hasBlackBox #-}
(+#) =
  \(S a) (S b) ->
    let z = a + b
    in  if z >= m then
          S (z - 2*m)
        else if z < negate m then
          S (z + 2*m)
        else
          S z
 where
  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE (-#) #-}
{-# ANN (-#) hasBlackBox #-}
(-#) =
  \(S a) (S b) ->
    let z = a - b
    in  if z < negate m then
          S (z + 2*m)
        else if z >= m then
          S (z - 2*m)
        else
          S z
 where
  m  = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE (*#) #-}
{-# ANN (*#) hasBlackBox #-}
(*#) = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a * b)
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE negate# #-}
{-# ANN negate# hasBlackBox #-}
negate# =
  \(S n) ->
    let z = negate n
    in  if z == m then S n else S z
 where
  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE abs# #-}
{-# ANN abs# hasBlackBox #-}
abs# =
  \(S n) ->
    let z = abs n
    in  if z == m then S n else S z
 where
  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE fromInteger# #-}
{-# ANN fromInteger# hasBlackBox #-}
fromInteger# :: forall n . KnownNat n => Integer -> Signed (n :: Nat)
fromInteger# = fromInteger_INLINE sz mB mask
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

{-# INLINE fromInteger_INLINE #-}
fromInteger_INLINE :: Int -> Integer -> Integer -> Integer -> Signed n
fromInteger_INLINE sz mb mask =
  \i -> let i1 = i .&. mask
            i2 = case i `shiftR` sz of
                   q | q .&. 1 == 0 -> i1
                     | otherwise    -> i1 - mb
        in  if sz < 0 then S 0 else S i2

instance ExtendingNum (Signed m) (Signed n) where
  type AResult (Signed m) (Signed n) = Signed (Max m n + 1)
  add  = plus#
  sub = minus#
  type MResult (Signed m) (Signed n) = Signed (m + n)
  mul = times#

plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1)
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE plus# #-}
{-# ANN plus# hasBlackBox #-}
plus# (S a) (S b) = S (a + b)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE minus# #-}
{-# ANN minus# hasBlackBox #-}
minus# (S a) (S b) = S (a - b)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE times# #-}
{-# ANN times# hasBlackBox #-}
times# :: Signed m -> Signed n -> Signed (m + n)
times# (S a) (S b) = S (a * b)

instance KnownNat n => Real (Signed n) where
  toRational = toRational . toInteger#

-- | __NB__: 'toInteger'/'fromIntegral' can cause unexpected truncation, as
-- 'Integer' is arbitrarily bounded during synthesis.  Prefer
-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.
instance KnownNat n => Integral (Signed n) where
  quot        = quot#
  rem         = rem#
  div         = div#
  mod         = mod#
  quotRem n d = (n `quot#` d,n `rem#` d)
  divMod  n d = (n `div#`  d,n `mod#` d)
  toInteger   = toInteger#

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE quot# #-}
{-# ANN quot# hasBlackBox #-}
quot# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n
quot# (S a) (S b)
  | a == minB && b == (-1) = S minB
  | otherwise = S (a `quot` b)
 where
  S minB = minBound @(Signed n)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE rem# #-}
{-# ANN rem# hasBlackBox #-}
rem# :: Signed n -> Signed n -> Signed n
rem# (S a) (S b) = S (a `rem` b)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE div# #-}
{-# ANN div# hasBlackBox #-}
div# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n
div# (S a) (S b)
  | a == minB && b == (-1) = S minB
  | otherwise = S (a `div` b)
 where
  S minB = minBound @(Signed n)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE mod# #-}
{-# ANN mod# hasBlackBox #-}
mod# :: Signed n -> Signed n -> Signed n
mod# (S a) (S b) = S (a `mod` b)

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE toInteger# #-}
{-# ANN toInteger# hasBlackBox #-}
toInteger# :: Signed n -> Integer
toInteger# (S n) = n

instance KnownNat n => PrintfArg (Signed n) where
  formatArg = formatArg . toInteger

instance KnownNat n => Parity (Signed n) where
  even = even . pack
  odd = odd . pack

instance KnownNat n => Bits (Signed n) where
  (.&.)             = and#
  (.|.)             = or#
  xor               = xor#
  complement        = complement#
  zeroBits          = 0
  bit i             = replaceBit i high 0
  setBit v i        = replaceBit i high v
  clearBit v i      = replaceBit i low  v
  complementBit v i = replaceBit i (BV.complement## (v ! i)) v
  testBit v i       = v ! i == 1
  bitSizeMaybe v    = Just (size# v)
  bitSize           = size#
  isSigned _        = True
  shiftL v i        = shiftL# v i
  shiftR v i        = shiftR# v i
  rotateL v i       = rotateL# v i
  rotateR v i       = rotateR# v i
  popCount s        = popCount (pack# s)

and#,or#,xor# :: forall n . KnownNat n => Signed n -> Signed n -> Signed n
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE and# #-}
{-# ANN and# hasBlackBox #-}
and# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a .&. b)
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE or# #-}
{-# ANN or# hasBlackBox #-}
or# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a .|. b)
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE xor# #-}
{-# ANN xor# hasBlackBox #-}
xor# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (xor a b)
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE complement# #-}
{-# ANN complement# hasBlackBox #-}
complement# :: forall n . KnownNat n => Signed n -> Signed n
complement# = \(S a) -> fromInteger_INLINE sz mB mask (complement a)
  where sz   = fromInteger (natVal (Proxy @n)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

shiftL#,shiftR#,rotateL#,rotateR# :: forall n . KnownNat n => Signed n -> Int -> Signed n
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE shiftL# #-}
{-# ANN shiftL# hasBlackBox #-}
shiftL# = \(S n) b ->
  if | b < 0     -> error $ "'shiftL' undefined for negative number: " ++ show b
     | b > sz    -> S 0
     | otherwise -> fromInteger_INLINE sz mB mask (shiftL n b)
 where
  sz   = fromInteger (natVal (Proxy @n)) - 1
  mB   = 1 `shiftL` sz
  mask = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE shiftR# #-}
{-# ANN shiftR# hasBlackBox #-}
shiftR# =
  \(S n) b ->
    if b >= 0 then
      fromInteger_INLINE sz mB mask (shiftR n b)
    else
      error $ "'shiftR' undefined for negative number: " ++ show b
 where
  sz   = fromInteger (natVal (Proxy @n)) - 1
  mB   = 1 `shiftL` sz
  mask = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE rotateL# #-}
{-# ANN rotateL# hasBlackBox #-}
rotateL# =
  \(S n) b ->
    if b >= 0 then
      let l    = shiftL n b'
          r    = shiftR n b'' .&. mask
          mask = 2 ^ b' - 1

          b'   = b `mod` sz
          b''  = sz - b'
      in  fromInteger_INLINE sz1 mB maskM (l .|. r)
    else
      error $ "'rotateL undefined for negative number: " ++ show b
 where
  sz    = fromInteger (natVal (Proxy @n))
  sz1   = sz-1
  mB    = 1 `shiftL` sz1
  maskM = mB - 1

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE rotateR# #-}
{-# ANN rotateR# hasBlackBox #-}
rotateR# =
  \(S n) b ->
    if b >= 0 then
      let l    = shiftR n b' .&. mask
          r    = shiftL n b''
          mask = 2 ^ b'' - 1

          b'  = b `mod` sz
          b'' = sz - b'
      in  fromInteger_INLINE sz1 mB maskM (l .|. r)
    else
      error $ "'rotateR' undefined for negative number: " ++ show b
 where
  sz    = fromInteger (natVal (Proxy @n))
  sz1   = sz - 1
  mB    = 1 `shiftL` sz1
  maskM = mB - 1

instance KnownNat n => FiniteBits (Signed n) where
  finiteBitSize        = size#
  countLeadingZeros  s = countLeadingZeros  (pack# s)
  countTrailingZeros s = countTrailingZeros (pack# s)

instance Resize Signed where
  resize       = resize#
  zeroExtend s = unpack# (0 ++# pack s)
  truncateB    = truncateB#

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE resize# #-}
{-# ANN resize# hasBlackBox #-}
resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m
resize# s@(S i)
  | natToNatural @m == 0 = S 0
  | n' <= m'  = extended
  | otherwise = truncated
  where
    n  = fromInteger (natVal s)
    n' = shiftL 1 n
    m' = shiftL mask 1
    extended = S i

    mask      = 1 `shiftL` fromInteger (natVal (Proxy @m) -1)
    i'        = i `mod` mask
    truncated = if testBit i (n-1)
                   then S (i' - mask)
                   else S i'

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# CLASH_OPAQUE truncateB# #-}
{-# ANN truncateB# hasBlackBox #-}
truncateB# :: forall m n . KnownNat m => Signed (m + n) -> Signed m
truncateB# = \(S n) -> fromInteger_INLINE sz mB mask n
  where sz   = fromInteger (natVal (Proxy @m)) - 1
        mB   = 1 `shiftL` sz
        mask = mB - 1

instance KnownNat n => Default (Signed n) where
  def = fromInteger# 0

instance KnownNat n => Lift (Signed n) where
  lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s))
  {-# NOINLINE lift #-}
#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped = liftTypedFromUntyped
#endif

#if MIN_VERSION_template_haskell(2,17,0)
decSigned :: Quote m => Integer -> m Type
#else
decSigned :: Integer -> TypeQ
#endif
decSigned n = appT (conT ''Signed) (litT $ numTyLit n)

instance KnownNat n => SaturatingNum (Signed n) where
  satAdd SatWrap  a b = a +# b
  satAdd SatBound a b =
    let r      = plus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> case msb a .&. msb b of
            0 -> maxBound#
            _ -> minBound#
  satAdd SatZero a b =
    let r      = plus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> fromInteger# 0
  satAdd SatError a b =
    let r      = plus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> errorX "Signed.satAdd: overflow/underflow"
  satAdd SatSymmetric a b =
    let r      = plus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> case msb a .&. msb b of
            0 -> maxBound#
            _ -> minBoundSym#

  satSub SatWrap a b = a -# b
  satSub SatBound a b =
    let r      = minus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> case BV.pack# (msb a) ++# BV.pack# (msb b) of
            2 -> minBound#
            _ -> maxBound#
  satSub SatZero a b =
    let r      = minus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> fromInteger# 0
  satSub SatError a b =
    let r      = minus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> errorX "Signed.satSub: overflow/underflow"
  satSub SatSymmetric a b =
    let r      = minus# a b
        (_,r') = split r
    in  case msb r `xor` msb r' of
          0 -> unpack# r'
          _ -> case BV.pack# (msb a) ++# BV.pack# (msb b) of
            2 -> minBoundSym#
            _ -> maxBound#

  satMul SatWrap a b = a *# b
  satMul SatBound a b =
    let r        = times# a b
        (rL,rR)  = split r
        overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.
                   reduceAnd (BV.pack# (msb rR) ++# pack rL)
    in  case overflow of
          1 -> unpack# rR
          _ -> case msb rL of
            0 -> maxBound#
            _ -> minBound#
  satMul SatZero a b =
    let r        = times# a b
        (rL,rR)  = split r
        overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.
                   reduceAnd (BV.pack# (msb rR) ++# pack rL)
    in  case overflow of
          1 -> unpack# rR
          _ -> fromInteger# 0
  satMul SatError a b =
    let r        = times# a b
        (rL,rR)  = split r
        overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.
                   reduceAnd (BV.pack# (msb rR) ++# pack rL)
    in  case overflow of
          1 -> unpack# rR
          _ -> errorX "Signed.satMul: overflow/underflow"
  satMul SatSymmetric a b =
    let r        = times# a b
        (rL,rR)  = split r
        overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.
                   reduceAnd (BV.pack# (msb rR) ++# pack rL)
    in  case overflow of
          1 -> unpack# rR
          _ -> case msb rL of
            0 -> maxBound#
            _ -> minBoundSym#

  satSucc SatError a
    | a == maxBound = errorX "Signed.satSucc: overflow"
  satSucc satMode a = satSub satMode a $ fromInteger# (-1)
  {-# INLINE satSucc #-}

  satPred SatError a
    | a == minBound = errorX "Signed.satPred: underflow"
  satPred satMode a = satAdd satMode a $ fromInteger# (-1)
  {-# INLINE satPred #-}

minBoundSym# :: KnownNat n => Signed n
minBoundSym# = minBound# +# fromInteger# 1

instance KnownNat n => Arbitrary (Signed n) where
  arbitrary = arbitraryBoundedIntegral
  shrink    = shrinkSizedSigned

shrinkSizedSigned :: (KnownNat n, Integral (p n)) => p n -> [p n]
shrinkSizedSigned x | natVal x < 2 = case toInteger x of
                                       0 -> []
                                       _ -> [0]
                    -- 'shrinkIntegral' uses "`quot` 2", which for sized types
                    -- less than 2 bits wide results in a division by zero.
                    --
                    -- See: https://github.com/clash-lang/clash-compiler/issues/153
                    | otherwise    = shrinkIntegral x
{-# INLINE shrinkSizedSigned #-}

instance KnownNat n => CoArbitrary (Signed n) where
  coarbitrary = coarbitraryIntegral

type instance Index   (Signed n) = Int
type instance IxValue (Signed n) = Bit
instance KnownNat n => Ixed (Signed n) where
  ix i f s = unpack# <$> BV.replaceBit# (pack# s) i
                     <$> f (BV.index# (pack# s) i)

instance (KnownNat n) => Ix (Signed n) where
  range (a, b) = [a..b]
  index ab@(a, b) x
    | inRange ab x = fromIntegral $ x - a
    | otherwise = error $ printf "Index (%d) out of range ((%d, %d))" x a b
  inRange (a, b) x = a <= x && x <= b

-- | Shift left that ties to zero on negative shifts
shiftL0 :: Integer -> Int -> Integer
#if MIN_VERSION_base(4,15,0)
shiftL0 = \a sh -> if sh >= 0 then shiftL a sh else 0
#else
shiftL0 = shiftL -- True for use with this module
#endif
{-# INLINE shiftL0 #-}