SymRotate.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :   Grisette.Internal.Core.Data.Class.SymRotate
-- Copyright   :   (c) Sirui Lu 2021-2023
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.Core.Data.Class.SymRotate
  ( SymRotate (..),
    DefaultFiniteBitsSymRotate (..),
  )
where

import Data.Bits (Bits (isSigned, rotate), FiniteBits (finiteBitSize))
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Word (Word16, Word32, Word64, Word8)

-- | The `symRotate` is similar to `rotate`, but accepts the type itself instead
-- of `Int` for the rotate amount. The function works on all inputs, including
-- the rotate amounts that are beyond the bit width of the value.
--
-- The `symRotateNegated` function rotates to the opposite direction of
-- `symRotate`. This function is introduced to handle the asymmetry of the range
-- of values.
class (Bits a) => SymRotate a where
  symRotate :: a -> a -> a
  symRotateNegated :: a -> a -> a

instance SymRotate Int where
  symRotate = rotate
  symRotateNegated a s
    | s /= minBound = rotate a (-s)
    | otherwise = rotate a (-(s + finiteBitSize s))

-- | A newtype wrapper. Use this to derive `SymRotate` for types that have
-- `FiniteBits` instances.
newtype DefaultFiniteBitsSymRotate a = DefaultFiniteBitsSymRotate
  { unDefaultFiniteBitsSymRotate :: a
  }
  deriving newtype (Eq, Bits)

instance
  (Integral a, FiniteBits a) =>
  SymRotate (DefaultFiniteBitsSymRotate a)
  where
  symRotate (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s)
    | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s
    | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s
    where
      symRotateUnsigned :: a -> a -> a
      symRotateUnsigned a s =
        rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))
      symRotateSigned :: a -> a -> a
      symRotateSigned a s
        | finiteBitSize s == 1 = a
        | finiteBitSize s == 2 = rotate a (fromIntegral s)
        | otherwise =
            rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))
  symRotateNegated (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s)
    | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s
    | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s
    where
      bs = fromIntegral (finiteBitSize a)
      smodbs = s `mod` bs
      symRotateUnsigned :: a -> a -> a
      symRotateUnsigned a _ =
        rotate a (fromIntegral (bs - smodbs))
      symRotateSigned :: a -> a -> a
      symRotateSigned a s
        | finiteBitSize a == 1 = a
        | finiteBitSize a == 2 = rotate a (-fromIntegral s)
        | otherwise =
            if smodbs > 0
              then rotate a (fromIntegral (bs - smodbs))
              else rotate a (fromIntegral (-smodbs))

deriving via (DefaultFiniteBitsSymRotate Int8) instance SymRotate Int8

deriving via (DefaultFiniteBitsSymRotate Int16) instance SymRotate Int16

deriving via (DefaultFiniteBitsSymRotate Int32) instance SymRotate Int32

deriving via (DefaultFiniteBitsSymRotate Int64) instance SymRotate Int64

deriving via (DefaultFiniteBitsSymRotate Word8) instance SymRotate Word8

deriving via (DefaultFiniteBitsSymRotate Word16) instance SymRotate Word16

deriving via (DefaultFiniteBitsSymRotate Word32) instance SymRotate Word32

deriving via (DefaultFiniteBitsSymRotate Word64) instance SymRotate Word64

deriving via (DefaultFiniteBitsSymRotate Word) instance SymRotate Word