module CLaSH.Sized.Signed
( Signed
, resizeS
, resizeS_wrap
)
where
import Data.Bits
import Data.Default
import Language.Haskell.TH
import Language.Haskell.TH.Syntax(Lift(..))
import GHC.TypeLits
import CLaSH.Bit
import CLaSH.Class.BitVector
import CLaSH.Promoted.Nat
import CLaSH.Sized.Vector
newtype Signed (n :: Nat) = S Integer
instance Eq (Signed n) where
(==) = eqS
eqS :: (Signed n) -> (Signed n) -> Bool
(S n) `eqS` (S m) = n == m
instance Ord (Signed n) where
(<) = ltS
(>=) = geS
(>) = gtS
(<=) = leS
ltS,geS,gtS,leS :: Signed n -> Signed n -> Bool
ltS (S n) (S m) = n < m
geS (S n) (S m) = n >= m
gtS (S n) (S m) = n > m
leS (S n) (S m) = n <= m
instance KnownNat n => Enum (Signed n) where
succ = plusS (fromIntegerS 1)
pred = minS (fromIntegerS 1)
toEnum = fromIntegerS . toInteger
fromEnum = fromEnum . toIntegerS
instance KnownNat n => Bounded (Signed n) where
minBound = minBoundS
maxBound = maxBoundS
minBoundS,maxBoundS :: forall n . KnownNat n => Signed n
minBoundS = S $ negate $ 2 ^ (fromSNat (snat :: SNat n) 1)
maxBoundS = S $ 2 ^ (fromSNat (snat :: SNat n) 1) 1
instance KnownNat n => Num (Signed n) where
(+) = plusS
() = minS
(*) = timesS
negate = negateS
abs = absS
signum = signumS
fromInteger = fromIntegerS
plusS,minS,timesS :: KnownNat n => Signed n -> Signed n -> Signed n
plusS (S a) (S b) = fromIntegerS_inlineable $ a + b
minS (S a) (S b) = fromIntegerS_inlineable $ a b
timesS (S a) (S b) = fromIntegerS_inlineable $ a * b
negateS,absS,signumS :: KnownNat n => Signed n -> Signed n
negateS (S n) = fromIntegerS_inlineable (0 n)
absS (S n) = fromIntegerS_inlineable (abs n)
signumS (S n) = fromIntegerS_inlineable (signum n)
fromIntegerS,fromIntegerS_inlineable :: forall n . KnownNat n => Integer -> Signed (n :: Nat)
fromIntegerS = fromIntegerS_inlineable
fromIntegerS_inlineable i
| nS == 0 = S 0
| otherwise = res
where
nS = fromSNat (snat :: SNat n)
sz = 2 ^ (nS 1)
res = case divMod i sz of
(s,i') | even s -> S i'
| otherwise -> S (i' sz)
instance KnownNat n => Real (Signed n) where
toRational = toRational . toIntegerS
instance KnownNat n => Integral (Signed n) where
quot = quotS
rem = remS
div = divS
mod = modS
quotRem = quotRemS
divMod = divModS
toInteger = toIntegerS
quotS,remS,divS,modS :: KnownNat n => Signed n -> Signed n -> Signed n
quotS = (fst.) . quotRemS_inlineable
remS = (snd.) . quotRemS_inlineable
divS = (fst.) . divModS_inlineable
modS = (snd.) . divModS_inlineable
quotRemS,divModS :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n)
quotRemS n d = (n `quotS` d,n `remS` d)
divModS n d = (n `divS` d,n `modS` d)
quotRemS_inlineable,divModS_inlineable :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n)
(S a) `quotRemS_inlineable` (S b) = let (a',b') = a `quotRem` b
in (fromIntegerS_inlineable a', fromIntegerS_inlineable b')
(S a) `divModS_inlineable` (S b) = let (a',b') = a `divMod` b
in (fromIntegerS_inlineable a', fromIntegerS_inlineable b')
toIntegerS :: Signed n -> Integer
toIntegerS (S n) = n
instance KnownNat n => Bits (Signed n) where
(.&.) = andS
(.|.) = orS
xor = xorS
complement = complementS
bit = bitS
testBit = testBitS
bitSizeMaybe = Just . finiteBitSizeS
isSigned = const True
shiftL = shiftLS
shiftR = shiftRS
rotateL = rotateLS
rotateR = rotateRS
popCount = popCountS
andS,orS,xorS :: KnownNat n => Signed n -> Signed n -> Signed n
(S a) `andS` (S b) = fromIntegerS_inlineable (a .&. b)
(S a) `orS` (S b) = fromIntegerS_inlineable (a .|. b)
(S a) `xorS` (S b) = fromIntegerS_inlineable (xor a b)
complementS :: KnownNat n => Signed n -> Signed n
complementS = fromBitVector . vmap complement . toBitVector
bitS :: KnownNat n => Int -> Signed n
bitS = fromIntegerS_inlineable . bit
testBitS :: Signed n -> Int -> Bool
testBitS (S n) i = testBit n i
shiftLS,shiftRS,rotateLS,rotateRS :: KnownNat n => Signed n -> Int -> Signed n
shiftLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers"
shiftLS (S n) b = fromIntegerS_inlineable (shiftL n b)
shiftRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers"
shiftRS (S n) b = fromIntegerS_inlineable (shiftR n b)
rotateLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers"
rotateLS n b = let b' = b `mod` finiteBitSizeS n
in shiftL n b' .|. shiftR n (finiteBitSizeS n b')
rotateRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers"
rotateRS n b = let b' = b `mod` finiteBitSizeS n
in shiftR n b' .|. shiftL n (finiteBitSizeS n b')
popCountS :: Signed n -> Int
popCountS (S n) = popCount n
instance KnownNat n => FiniteBits (Signed n) where
finiteBitSize = finiteBitSizeS
finiteBitSizeS :: forall n . KnownNat n => Signed n -> Int
finiteBitSizeS _ = fromInteger $ fromSNat (snat :: SNat n)
instance Show (Signed n) where
show (S n) = show n
instance KnownNat n => Default (Signed n) where
def = fromIntegerS 0
instance KnownNat n => Lift (Signed n) where
lift (S i) = sigE [| fromIntegerS i |] (decSigned $ fromSNat (snat :: (SNat n)))
decSigned :: Integer -> TypeQ
decSigned n = appT (conT ''Signed) (litT $ numTyLit n)
instance BitVector (Signed n) where
type BitSize (Signed n) = n
toBV = toBitVector
fromBV = fromBitVector
toBitVector :: KnownNat n => Signed n -> Vec n Bit
toBitVector (S m) = vreverse $ vmap (\x -> if odd x then H else L) $ viterateI (`div` 2) m
fromBitVector :: KnownNat n => Vec n Bit -> Signed n
fromBitVector = fromBitList . reverse . toList
fromBitList :: KnownNat n => [Bit] -> Signed n
fromBitList l = fromIntegerS_inlineable
$ sum [ n
| (n,b) <- zip (iterate (*2) 1) l
, b == H
]
resizeS :: forall n m . (KnownNat n, KnownNat m) => Signed n -> Signed m
resizeS s@(S n) | n' <= m' = fromIntegerS_inlineable n
| otherwise = case l of
(x:xs) -> fromBitList $ reverse $ x : (drop (n' m') xs)
_ -> error "resizeS impossible case: empty list"
where
n' = fromInteger $ fromSNat (snat :: SNat n) :: Int
m' = fromInteger $ fromSNat (snat :: SNat m) :: Int
l = toList $ toBitVector s
resizeS_wrap :: KnownNat m => Signed n -> Signed m
resizeS_wrap s@(S n) = fromIntegerS_inlineable n