toBoundedIntegral: an adaptation of fromIntegral that respects bounds

output.txt

$ rm -rf ToBoundedIntegral *.{o,hi}; ghc -ddump-rule-firings -O ToBoundedIntegral.hs; ./ToBoundedIntegral
[1 of 1] Compiling Main             ( ToBoundedIntegral.hs, ToBoundedIntegral.o )
Rule fired: Class op >
Rule fired: Class op <
Rule fired: Class op maxBound
Rule fired: toBoundedIntegral/Word32->Int
Rule fired: Class op $p1Integral
Rule fired: Class op $p1Real
Rule fired: fromIntegral/Word32->a
Rule fired: fromIntegral/Word->Int
Rule fired: Class op maxBound
Rule fired: toBoundedIntegral/Word64->Word
Rule fired: Class op maxBound
Rule fired: toBoundedIntegral/Word32->Word32
Rule fired: Class op maxBound
Rule fired: toBoundedIntegral/CInt->a
Rule fired: toBoundedIntegral/Int32->Int
Rule fired: Class op $p1Integral
Rule fired: Class op $p1Real
Rule fired: fromIntegral/Int32->a
Rule fired: fromIntegral/Int->Int
Rule fired: Class op minBound
Rule fired: Class op >>
Rule fired: Class op >>
Rule fired: Class op >>
Rule fired: Class op >>
Rule fired: Class op minBound
Rule fired: Class op maxBound
Rule fired: Class op $p1Integral
Rule fired: Class op $p1Real
Rule fired: Class op toInteger
Rule fired: Class op fromInteger
Rule fired: Class op toInteger
Rule fired: smallInteger
Rule fired: Class op toInteger
Rule fired: smallInteger
Rule fired: word2Int#
Rule fired: Class op show
Rule fired: >#
Rule fired: tagToEnum#
Rule fired: Class op showsPrec
Rule fired: ++
Rule fired: Class op show
Rule fired: >#
Rule fired: tagToEnum#
Rule fired: Class op showsPrec
Rule fired: ++
Rule fired: Class op show
Rule fired: >#
Rule fired: tagToEnum#
Rule fired: Class op showsPrec
Rule fired: word2Int#
Rule fired: ++
Rule fired: Class op show
Rule fired: >#
Rule fired: tagToEnum#
Rule fired: Class op showsPrec
Rule fired: ++
Rule fired: Class op show
Rule fired: foldr/app
Rule fired: foldr/app
Rule fired: foldr/app
Rule fired: foldr/app
Rule fired: Class op toInteger
Rule fired: smallInteger
Rule fired: Class op maxBound
Rule fired: Class op toInteger
Rule fired: smallInteger
Rule fired: gtInteger#
Rule fired: tagToEnum#
Rule fired: Class op minBound
Rule fired: Class op toInteger
Rule fired: smallInteger
Rule fired: ltInteger#
Rule fired: tagToEnum#
Linking ToBoundedIntegral ...
Just 4294967295
Just 18446744073709551615
Just 4294967295
Just 2147483647
Nothing

ToBoundedIntegral.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}

#include "MachDeps.h"

import GHC.Base
import GHC.Int
import GHC.Word
import Foreign.C.Types

toBoundedIntegral :: (Integral a, Integral b, Bounded b) => a -> Maybe b
toBoundedIntegral x
  | y > toInteger (maxBound `asTypeOf` z) = Nothing
  | y < toInteger (minBound `asTypeOf` z) = Nothing
  | otherwise                             = Just $! z
  where
    y = toInteger x
    z = fromInteger y
{-# NOINLINE [1] toBoundedIntegral #-}

-- Identity rules: The integral RHS and the LHS types are identical.

{-# RULES
"toBoundedIntegral/Int->Int"       toBoundedIntegral = Just :: Int    -> Maybe Int
"toBoundedIntegral/Int8->Int8"     toBoundedIntegral = Just :: Int8   -> Maybe Int8
"toBoundedIntegral/Int16->Int16"   toBoundedIntegral = Just :: Int16  -> Maybe Int16
"toBoundedIntegral/Int32->Int32"   toBoundedIntegral = Just :: Int32  -> Maybe Int32
"toBoundedIntegral/Int64->Int64"   toBoundedIntegral = Just :: Int64  -> Maybe Int64

"toBoundedIntegral/Word->Word"     toBoundedIntegral = Just :: Word   -> Maybe Word
"toBoundedIntegral/Word8->Word8"   toBoundedIntegral = Just :: Word8  -> Maybe Word8
"toBoundedIntegral/Word16->Word16" toBoundedIntegral = Just :: Word16 -> Maybe Word16
"toBoundedIntegral/Word32->Word32" toBoundedIntegral = Just :: Word32 -> Maybe Word32
"toBoundedIntegral/Word64->Word64" toBoundedIntegral = Just :: Word64 -> Maybe Word64

"toBoundedIntegral/CChar->CChar"           toBoundedIntegral = Just :: CChar      -> Maybe CChar
"toBoundedIntegral/CSChar->CSChar"         toBoundedIntegral = Just :: CSChar     -> Maybe CSChar
"toBoundedIntegral/CUChar->CUChar"         toBoundedIntegral = Just :: CUChar     -> Maybe CUChar
"toBoundedIntegral/CShort->CShort"         toBoundedIntegral = Just :: CShort     -> Maybe CShort
"toBoundedIntegral/CUShort->CUShort"       toBoundedIntegral = Just :: CUShort    -> Maybe CUShort
"toBoundedIntegral/CInt->CInt"             toBoundedIntegral = Just :: CInt       -> Maybe CInt
"toBoundedIntegral/CUInt->CUInt"           toBoundedIntegral = Just :: CUInt      -> Maybe CUInt
"toBoundedIntegral/CLong->CLong"           toBoundedIntegral = Just :: CLong      -> Maybe CLong
"toBoundedIntegral/CULong->CULong"         toBoundedIntegral = Just :: CULong     -> Maybe CULong
"toBoundedIntegral/CPtrdiff->CPtrdiff"     toBoundedIntegral = Just :: CPtrdiff   -> Maybe CPtrdiff
"toBoundedIntegral/CSize->CSize"           toBoundedIntegral = Just :: CSize      -> Maybe CSize
"toBoundedIntegral/CWchar->CWchar"         toBoundedIntegral = Just :: CWchar     -> Maybe CWchar
"toBoundedIntegral/CSigAtomic->CSigAtomic" toBoundedIntegral = Just :: CSigAtomic -> Maybe CSigAtomic
"toBoundedIntegral/CLLong->CLLong"         toBoundedIntegral = Just :: CLLong     -> Maybe CLLong
"toBoundedIntegral/CULLong->CULLong"       toBoundedIntegral = Just :: CULLong    -> Maybe CULLong
"toBoundedIntegral/CIntPtr->CIntPtr"       toBoundedIntegral = Just :: CIntPtr    -> Maybe CIntPtr
"toBoundedIntegral/CUIntPtr->CUIntPtr"     toBoundedIntegral = Just :: CUIntPtr   -> Maybe CUIntPtr
"toBoundedIntegral/CIntMax->CIntMax"       toBoundedIntegral = Just :: CIntMax    -> Maybe CIntMax
"toBoundedIntegral/CUIntMax->CUIntMax"     toBoundedIntegral = Just :: CUIntMax   -> Maybe CUIntMax
  #-}

-- Subsumption rules: The integral RHS type is strictly larger than the LHS type.

-- 8-bit signed
{-# RULES
"toBoundedIntegral/Int8->Int"       toBoundedIntegral = Just . fromIntegral :: Int8 -> Maybe Int
"toBoundedIntegral/Int8->Int16"     toBoundedIntegral = Just . fromIntegral :: Int8 -> Maybe Int16
"toBoundedIntegral/Int8->Int32"     toBoundedIntegral = Just . fromIntegral :: Int8 -> Maybe Int32
"toBoundedIntegral/Int8->Int64"     toBoundedIntegral = Just . fromIntegral :: Int8 -> Maybe Int64
  #-}

-- 8-bit unsigned
{-# RULES
"toBoundedIntegral/Word8->Int"      toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Int
"toBoundedIntegral/Word8->Int16"    toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Int16
"toBoundedIntegral/Word8->Int32"    toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Int32
"toBoundedIntegral/Word8->Int64"    toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Int64

"toBoundedIntegral/Word8->Word"     toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Word
"toBoundedIntegral/Word8->Word16"   toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Word16
"toBoundedIntegral/Word8->Word32"   toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Word32
"toBoundedIntegral/Word8->Word64"   toBoundedIntegral = Just . fromIntegral :: Word8 -> Maybe Word64
  #-}

-- 16-bit signed
{-# RULES
"toBoundedIntegral/Int16->Int"      toBoundedIntegral = Just . fromIntegral :: Int16 -> Maybe Int
"toBoundedIntegral/Int16->Int32"    toBoundedIntegral = Just . fromIntegral :: Int16 -> Maybe Int32
"toBoundedIntegral/Int16->Int64"    toBoundedIntegral = Just . fromIntegral :: Int16 -> Maybe Int64
  #-}

-- 16-bit unsigned
{-# RULES
"toBoundedIntegral/Word16->Int"     toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Int
"toBoundedIntegral/Word16->Int32"   toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Int32
"toBoundedIntegral/Word16->Int64"   toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Int64

"toBoundedIntegral/Word16->Word"    toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Word
"toBoundedIntegral/Word16->Word32"  toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Word32
"toBoundedIntegral/Word16->Word64"  toBoundedIntegral = Just . fromIntegral :: Word16 -> Maybe Word64
  #-}

-- 32-bit signed
{-# RULES
"toBoundedIntegral/Int32->Int64"    toBoundedIntegral = Just . fromIntegral :: Int32 -> Maybe Int64
  #-}

-- 32-bit unsigned
{-# RULES
"toBoundedIntegral/Word32->Word64"  toBoundedIntegral = Just . fromIntegral :: Word32 -> Maybe Word64
  #-}

-- Identity and subsumption rules dependent on representation

#if WORD_SIZE_IN_BITS == 32
-- The integral RHS and LHS types have the same representation.
{-# RULES
"toBoundedIntegral/Int32->Int"      toBoundedIntegral = \(I32# x) -> Just (I# x)
"toBoundedIntegral/Word32->Word"    toBoundedIntegral = \(W32# x) -> Just (W# x)
"toBoundedIntegral/Int->Int32"      toBoundedIntegral = \(I# x) -> Just (I32# x)
"toBoundedIntegral/Word->Word32"    toBoundedIntegral = \(W# x) -> Just (W32# x)
  #-}
#elif WORD_SIZE_IN_BITS > 32
-- The integral RHS type has a strictly larger representation than the LHS type.
{-# RULES
"toBoundedIntegral/Int32->Int"      toBoundedIntegral = Just . fromIntegral :: Int32 -> Maybe Int
"toBoundedIntegral/Word32->Int"     toBoundedIntegral = Just . fromIntegral :: Word32 -> Maybe Int
"toBoundedIntegral/Word32->Word"    toBoundedIntegral = Just . fromIntegral :: Word32 -> Maybe Word
  #-}
#endif

#if WORD_SIZE_IN_BITS == 64
-- The integral RHS and LHS types have the same representation.
{-# RULES
"toBoundedIntegral/Int64->Int"      toBoundedIntegral = \(I64# x) -> Just (I# x)
"toBoundedIntegral/Word64->Word"    toBoundedIntegral = \(W64# x) -> Just (W# x)
"toBoundedIntegral/Int->Int64"      toBoundedIntegral = \(I# x) -> Just (I64# x)
"toBoundedIntegral/Word->Word64"    toBoundedIntegral = \(W# x) -> Just (W64# x)
  #-}
#endif

-- Wrapper rules

{-# RULES
"toBoundedIntegral/CChar->a"        toBoundedIntegral = \(CChar      x) -> toBoundedIntegral x
"toBoundedIntegral/CSChar->a"       toBoundedIntegral = \(CSChar     x) -> toBoundedIntegral x
"toBoundedIntegral/CUChar->a"       toBoundedIntegral = \(CUChar     x) -> toBoundedIntegral x
"toBoundedIntegral/CShort->a"       toBoundedIntegral = \(CShort     x) -> toBoundedIntegral x
"toBoundedIntegral/CUShort->a"      toBoundedIntegral = \(CUShort    x) -> toBoundedIntegral x
"toBoundedIntegral/CInt->a"         toBoundedIntegral = \(CInt       x) -> toBoundedIntegral x
"toBoundedIntegral/CUInt->a"        toBoundedIntegral = \(CUInt      x) -> toBoundedIntegral x
"toBoundedIntegral/CLong->a"        toBoundedIntegral = \(CLong      x) -> toBoundedIntegral x
"toBoundedIntegral/CULong->a"       toBoundedIntegral = \(CULong     x) -> toBoundedIntegral x
"toBoundedIntegral/CPtrdiff->a"     toBoundedIntegral = \(CPtrdiff   x) -> toBoundedIntegral x
"toBoundedIntegral/CSize->a"        toBoundedIntegral = \(CSize      x) -> toBoundedIntegral x
"toBoundedIntegral/CWchar->a"       toBoundedIntegral = \(CWchar     x) -> toBoundedIntegral x
"toBoundedIntegral/CSigAtomic->a"   toBoundedIntegral = \(CSigAtomic x) -> toBoundedIntegral x
"toBoundedIntegral/CLLong->a"       toBoundedIntegral = \(CLLong     x) -> toBoundedIntegral x
"toBoundedIntegral/CULLong->a"      toBoundedIntegral = \(CULLong    x) -> toBoundedIntegral x
"toBoundedIntegral/CIntPtr->a"      toBoundedIntegral = \(CIntPtr    x) -> toBoundedIntegral x
"toBoundedIntegral/CUIntPtr->a"     toBoundedIntegral = \(CUIntPtr   x) -> toBoundedIntegral x
"toBoundedIntegral/CIntMax->a"      toBoundedIntegral = \(CIntMax    x) -> toBoundedIntegral x
"toBoundedIntegral/CUIntMax->a"     toBoundedIntegral = \(CUIntMax   x) -> toBoundedIntegral x

"toBoundedIntegral/a->CChar"        toBoundedIntegral = fmap CChar      . toBoundedIntegral
"toBoundedIntegral/a->CSChar"       toBoundedIntegral = fmap CSChar     . toBoundedIntegral
"toBoundedIntegral/a->CUChar"       toBoundedIntegral = fmap CUChar     . toBoundedIntegral
"toBoundedIntegral/a->CShort"       toBoundedIntegral = fmap CShort     . toBoundedIntegral
"toBoundedIntegral/a->CUShort"      toBoundedIntegral = fmap CUShort    . toBoundedIntegral
"toBoundedIntegral/a->CInt"         toBoundedIntegral = fmap CInt       . toBoundedIntegral
"toBoundedIntegral/a->CUInt"        toBoundedIntegral = fmap CUInt      . toBoundedIntegral
"toBoundedIntegral/a->CLong"        toBoundedIntegral = fmap CLong      . toBoundedIntegral
"toBoundedIntegral/a->CULong"       toBoundedIntegral = fmap CULong     . toBoundedIntegral
"toBoundedIntegral/a->CPtrdiff"     toBoundedIntegral = fmap CPtrdiff   . toBoundedIntegral
"toBoundedIntegral/a->CSize"        toBoundedIntegral = fmap CSize      . toBoundedIntegral
"toBoundedIntegral/a->CWchar"       toBoundedIntegral = fmap CWchar     . toBoundedIntegral
"toBoundedIntegral/a->CSigAtomic"   toBoundedIntegral = fmap CSigAtomic . toBoundedIntegral
"toBoundedIntegral/a->CLLong"       toBoundedIntegral = fmap CLLong     . toBoundedIntegral
"toBoundedIntegral/a->CULLong"      toBoundedIntegral = fmap CULLong    . toBoundedIntegral
"toBoundedIntegral/a->CIntPtr"      toBoundedIntegral = fmap CIntPtr    . toBoundedIntegral
"toBoundedIntegral/a->CUIntPtr"     toBoundedIntegral = fmap CUIntPtr   . toBoundedIntegral
"toBoundedIntegral/a->CIntMax"      toBoundedIntegral = fmap CIntMax    . toBoundedIntegral
"toBoundedIntegral/a->CUIntMax"     toBoundedIntegral = fmap CUIntMax   . toBoundedIntegral
  #-}

main :: IO ()
main = do
  print (toBoundedIntegral (maxBound :: Word32) :: Maybe Int)
  print (toBoundedIntegral (maxBound :: Word64) :: Maybe Word)
  print (toBoundedIntegral (maxBound :: Word32) :: Maybe Word32)
  print (toBoundedIntegral (maxBound :: CInt)   :: Maybe Int)
  print (toBoundedIntegral (minBound :: Int64)  :: Maybe Int32)