clash/Data/Param/Signed.hs

   1 {-# LANGUAGE  TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
   2 module Data.Param.Signed
   3   ( Signed
   4   , resizeSigned
   5   ) where
   6
   7 import Language.Haskell.TH
   8 import Language.Haskell.TH.Syntax (Lift(..))
   9 import qualified Data.Bits as B
  10 import Types
  11 import Types.Data.Num.Decimal.Literals.TH
  12
  13 import Data.Param.Integer
  14
  15 instance NaturalT nT => Lift (Signed nT) where
  16   lift (Signed i) = sigE [| (Signed i) |] (decSignedT (fromIntegerT (undefined :: nT)))
  17
  18 decSignedT :: Integer -> Q Type
  19 decSignedT n = appT (conT (''Signed)) (decLiteralT n)
  20
  21 resizeSigned :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'
  22 resizeSigned a = fromInteger (toInteger a)
  23
  24 sizeT :: Signed nT
  25       -> nT
  26 sizeT _ = undefined
  27
  28 mask :: forall nT . NaturalT nT
  29      => nT
  30      -> Integer
  31 mask _ = B.bit (fromIntegerT (undefined :: nT)) - 1
  32
  33 signBit :: forall nT . NaturalT nT
  34         => nT
  35         -> Int
  36 signBit _ = fromIntegerT (undefined :: nT) - 1
  37
  38 isNegative :: forall nT . NaturalT nT
  39            => Signed nT
  40            -> Bool
  41 isNegative (Signed x) =
  42     B.testBit x $ signBit (undefined :: nT)
  43
  44 instance NaturalT nT => Eq (Signed nT) where
  45     (Signed x) == (Signed y) = x == y
  46     (Signed x) /= (Signed y) = x /= y
  47
  48 instance NaturalT nT => Show (Signed nT) where
  49     showsPrec prec n =
  50         showsPrec prec $ toInteger n
  51
  52 instance NaturalT nT => Read (Signed nT) where
  53     readsPrec prec str =
  54         [ (fromInteger n, str)
  55         | (n, str) <- readsPrec prec str ]
  56
  57 instance NaturalT nT => Ord (Signed nT) where
  58     a `compare` b = toInteger a `compare` toInteger b
  59
  60 instance NaturalT nT => Bounded (Signed nT) where
  61     minBound = Signed $ negate $ 1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)
  62     maxBound = Signed $ (1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1
  63
  64 instance NaturalT nT => Enum (Signed nT) where
  65     succ x
  66        | x == maxBound  = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
  67        | otherwise      = x + 1
  68     pred x
  69        | x == minBound  = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
  70        | otherwise      = x - 1
  71
  72     fromEnum (Signed x)
  73         | x > toInteger (maxBound :: Int) =
  74             error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Int"
  75         | x < toInteger (minBound :: Int) =
  76             error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Int"
  77         | otherwise =
  78             fromInteger x
  79     toEnum x
  80         | x' > toInteger (maxBound :: Signed nT) =
  81             error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
  82         | x' < toInteger (minBound :: Signed nT) =
  83             error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
  84         | otherwise =
  85             fromInteger x'
  86             where x' = toInteger x
  87
  88 instance NaturalT nT => Num (Signed nT) where
  89     (Signed a) + (Signed b) =
  90         fromInteger $ a + b
  91     (Signed a) * (Signed b) =
  92         fromInteger $ a * b
  93     negate (Signed n) =
  94         fromInteger $ (n `B.xor` mask (undefined :: nT)) + 1
  95     a - b =
  96         a + (negate b)
  97
  98     fromInteger n
  99       | n > 0 =
 100         Signed $ n B..&. mask (undefined :: nT)
 101     fromInteger n
 102       | n < 0 =
 103         negate $ fromInteger $ negate n
 104     fromInteger _ =
 105         Signed 0
 106
 107     abs s
 108       | isNegative s =
 109           negate s
 110       | otherwise =
 111           s
 112     signum s
 113       | isNegative s =
 114           -1
 115       | s == 0 =
 116           0
 117       | otherwise =
 118           1
 119
 120 instance NaturalT nT => Real (Signed nT) where
 121     toRational n = toRational $ toInteger n
 122
 123 instance NaturalT nT => Integral (Signed nT) where
 124     a `quot` b =
 125         fromInteger $ toInteger a `quot` toInteger b
 126     a `rem` b =
 127         fromInteger $ toInteger a `rem` toInteger b
 128     a `div` b =
 129         fromInteger $ toInteger a `div` toInteger b
 130     a `mod` b =
 131         fromInteger $ toInteger a `mod` toInteger b
 132     a `quotRem` b =
 133         let (quot, rem) = toInteger a `quotRem` toInteger b
 134         in (fromInteger quot, fromInteger rem)
 135     a `divMod` b =
 136         let (div, mod) = toInteger a `divMod` toInteger b
 137         in (fromInteger div, fromInteger mod)
 138     toInteger s@(Signed x) =
 139         if isNegative s
 140            then let Signed x' = negate s in negate x'
 141            else x
 142
 143 instance NaturalT nT => B.Bits (Signed nT) where
 144     (Signed a) .&. (Signed b) = Signed $ a B..&. b
 145     (Signed a) .|. (Signed b) = Signed $ a B..|. b
 146     (Signed a) `xor` Signed b = Signed $ a `B.xor` b
 147     complement (Signed x) = Signed $ x `B.xor` mask (undefined :: nT)
 148     (Signed x) `shiftL` b
 149       | b < 0 = error $ "Bits.shiftL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
 150       | otherwise =
 151         Signed $ mask (undefined :: nT) B..&. (x `B.shiftL` b)
 152     s@(Signed x) `shiftR` b
 153       | b < 0 = error $ "Bits.shiftR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
 154       | isNegative s =
 155         Signed $ mask (undefined :: nT) B..&.
 156             ((x `B.shiftR` b) B..|. (mask (undefined :: nT) `B.shiftL` (fromIntegerT (undefined :: nT) - b)))
 157       | otherwise =
 158         Signed $ (mask (undefined :: nT)) B..&. (x `B.shiftR` b)
 159     (Signed a) `rotateL` b
 160       | b < 0 =
 161         error $ "Bits.rotateL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
 162       | otherwise =
 163         Signed $ mask (undefined :: nT) B..&.
 164             ((a `B.shiftL` b) B..|. (a `B.shiftR` (fromIntegerT (undefined :: nT) - b)))
 165     (Signed a) `rotateR` b
 166       | b < 0 =
 167         error $ "Bits.rotateR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
 168       | otherwise =
 169         Signed $ mask (undefined :: nT) B..&.
 170             ((a `B.shiftR` b) B..|. (a `B.shiftL` (fromIntegerT (undefined :: nT) - b)))
 171     bitSize _ = fromIntegerT (undefined :: nT)
 172     isSigned _ = True
 173
 174 instance NaturalT nT => HWBits (Signed nT) where
 175   a `shiftL` b = a `B.shiftL` (fromInteger (toInteger b))
 176   a `shiftR` b = a `B.shiftR` (fromInteger (toInteger b))