Skip to content

Commit ffcf904

Browse files
hvrhvr
committed
Leverage int-cast for statically checked int conversions
This reduces the amount of `fromIntegral` conversions that need to be audited by humans...
1 parent a8fe8c3 commit ffcf904

File tree

7 files changed

+120
-108
lines changed

7 files changed

+120
-108
lines changed

‎msgpack/msgpack.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -79,6 +79,7 @@ library
7979
, deepseq >= 1.3 && < 1.5
8080
, binary >= 0.7.1 && < 0.9
8181
, time >= 1.4.2 && < 1.9
82+
, int-cast >= 0.1.1 && < 0.3
8283
, array >= 0.5.0 && < 0.6
8384

8485
ghc-options: -Wall

‎msgpack/src/Compat/Binary.hs

+60-19
Original file line numberDiff line numberDiff line change
@@ -6,65 +6,106 @@
66
module Compat.Binary
77
( Binary(put, get)
88

9-
, runPut', runPut, PutM, Put
10-
, runGet', runGet, Get
9+
, runPut', Bin.runPut, Bin.PutM, Put
10+
, runGet', Bin.runGet, Get
1111

12-
, getWord64be, putWord64be
13-
, getWord32be, putWord32be
14-
, getWord16be, putWord16be
15-
, getWord8 , putWord8
12+
, Bin.getWord64be, Bin.putWord64be
13+
, Bin.getWord32be, Bin.putWord32be
14+
, Bin.getWord16be, Bin.putWord16be
15+
, Bin.getWord8 , Bin.putWord8
16+
17+
, getInt64be, putInt64be
18+
, getInt32be, putInt32be
19+
, getInt16be, putInt16be
20+
, getInt8 , putInt8
1621

1722
, getFloat32be, putFloat32be
1823
, getFloat64be, putFloat64be
1924

20-
, getByteString, putByteString
25+
, Bin.getByteString, Bin.putByteString
2126

2227
-- convenience
2328
, Data.Word.Word, Word8, Word16, Word32, Word64
2429
, Data.Int.Int, Int8, Int16, Int32, Int64
2530
) where
2631

32+
import Control.Applicative
2733
import qualified Data.ByteString as BS
2834
import qualified Data.ByteString.Lazy as BL
35+
import Data.IntCast
2936

3037
import Data.Array.ST (MArray, STUArray, newArray, readArray)
3138
import Data.Array.Unsafe (castSTUArray)
32-
import Data.Binary
33-
import Data.Binary.Get
34-
import Data.Binary.Put
39+
import Data.Binary (Binary (get, put), Get, Put)
40+
import qualified Data.Binary.Get as Bin
41+
import qualified Data.Binary.Put as Bin
3542
import Data.Int
3643
import Data.Word
3744
import GHC.ST (ST, runST)
3845

3946

4047
runGet' :: BS.ByteString -> Get a -> Maybe a
41-
runGet' bs0 g = case pushEndOfInput (runGetIncremental g `pushChunk` bs0) of
42-
Done bs _ x
48+
runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of
49+
Bin.Done bs _ x
4350
| BS.null bs -> return x
4451
| otherwise -> fail "trailing data"
45-
Partial _ -> fail "eof"
46-
Fail _ _ msg -> fail msg
52+
Bin.Partial _ -> fail "eof"
53+
Bin.Fail _ _ msg -> fail msg
4754

4855
runPut' :: Put -> BS.ByteString
49-
runPut' = BL.toStrict . runPut
56+
runPut' = BL.toStrict . Bin.runPut
57+
58+
59+
-- NB: once we drop support for binary < 0.8.1 we can drop the ops below
60+
61+
{-# INLINE getInt8 #-}
62+
getInt8 :: Get Int8
63+
getInt8 = intCastIso <$> Bin.getWord8
64+
65+
{-# INLINE getInt16be #-}
66+
getInt16be :: Get Int16
67+
getInt16be = intCastIso <$> Bin.getWord16be
68+
69+
{-# INLINE getInt32be #-}
70+
getInt32be :: Get Int32
71+
getInt32be = intCastIso <$> Bin.getWord32be
72+
73+
{-# INLINE getInt64be #-}
74+
getInt64be :: Get Int64
75+
getInt64be = intCastIso <$> Bin.getWord64be
76+
77+
{-# INLINE putInt8 #-}
78+
putInt8 :: Int8 -> Put
79+
putInt8 x = Bin.putWord8 (intCastIso x)
80+
81+
{-# INLINE putInt16be #-}
82+
putInt16be :: Int16 -> Put
83+
putInt16be x = Bin.putWord16be (intCastIso x)
84+
85+
{-# INLINE putInt32be #-}
86+
putInt32be :: Int32 -> Put
87+
putInt32be x = Bin.putWord32be (intCastIso x)
5088

89+
{-# INLINE putInt64be #-}
90+
putInt64be :: Int64 -> Put
91+
putInt64be x = Bin.putWord64be (intCastIso x)
5192

5293
-- NB: Once we drop support for binary < 0.8.4 we can use @binary@'s own {get,put}{Double,Float}be operations
5394

5495
putFloat32be :: Float -> Put
55-
putFloat32be x = putWord32be (runST (cast x))
96+
putFloat32be x = Bin.putWord32be (runST (cast x))
5697

5798
putFloat64be :: Double -> Put
58-
putFloat64be x = putWord64be (runST (cast x))
99+
putFloat64be x = Bin.putWord64be (runST (cast x))
59100

60101
getFloat32be :: Get Float
61102
getFloat32be = do
62-
x <- getWord32be
103+
x <- Bin.getWord32be
63104
return (runST (cast x))
64105

65106
getFloat64be :: Get Double
66107
getFloat64be = do
67-
x <- getWord64be
108+
x <- Bin.getWord64be
68109
return (runST (cast x))
69110

70111
-- See https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa/7002812#7002812

‎msgpack/src/Data/MessagePack/Get.hs

+10-21
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Control.Applicative
2222
import Control.Monad
2323
import qualified Data.ByteString as S
2424
import Data.Int
25+
import Data.IntCast
2526
import qualified Data.Text as T
2627
import qualified Data.Text.Encoding as T
2728
import qualified Data.Vector as V
@@ -86,8 +87,8 @@ getStr :: Get T.Text
8687
getStr = do
8788
len <- getWord8 >>= \case
8889
t | Just sz <- is_TAG_fixstr t -> pure sz
89-
TAG_str8 -> fromIntegral <$> getWord8
90-
TAG_str16 -> fromIntegral <$> getWord16be
90+
TAG_str8 -> intCast <$> getWord8
91+
TAG_str16 -> intCast <$> getWord16be
9192
TAG_str32 -> getWord32be
9293
_ -> empty
9394

@@ -100,8 +101,8 @@ getStr = do
100101
getBin :: Get S.ByteString
101102
getBin = do
102103
len <- getWord8 >>= \case
103-
TAG_bin8 -> fromIntegral <$> getWord8
104-
TAG_bin16 -> fromIntegral <$> getWord16be
104+
TAG_bin8 -> intCast <$> getWord8
105+
TAG_bin16 -> intCast <$> getWord16be
105106
TAG_bin32 -> getWord32be
106107
_ -> empty
107108
len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len
@@ -111,7 +112,7 @@ getArray :: Get a -> Get (V.Vector a)
111112
getArray g = do
112113
len <- getWord8 >>= \case
113114
t | Just sz <- is_TAG_fixarray t -> pure sz
114-
TAG_array16 -> fromIntegral <$> getWord16be
115+
TAG_array16 -> intCast <$> getWord16be
115116
TAG_array32 -> getWord32be
116117
_ -> empty
117118
len' <- fromSizeM "getArray: data exceeds capacity of Vector" len
@@ -121,7 +122,7 @@ getMap :: Get a -> Get b -> Get (V.Vector (a, b))
121122
getMap k v = do
122123
len <- getWord8 >>= \case
123124
t | Just sz <- is_TAG_fixmap t -> pure sz
124-
TAG_map16 -> fromIntegral <$> getWord16be
125+
TAG_map16 -> intCast <$> getWord16be
125126
TAG_map32 -> getWord32be
126127
_ -> empty
127128
len' <- fromSizeM "getMap: data exceeds capacity of Vector" len
@@ -141,24 +142,12 @@ getExt' getdat = do
141142
TAG_fixext4 -> return 4
142143
TAG_fixext8 -> return 8
143144
TAG_fixext16 -> return 16
144-
TAG_ext8 -> fromIntegral <$> getWord8
145-
TAG_ext16 -> fromIntegral <$> getWord16be
145+
TAG_ext8 -> intCast <$> getWord8
146+
TAG_ext16 -> intCast <$> getWord16be
146147
TAG_ext32 -> getWord32be
147148
_ -> empty
148149
typ <- getWord8
149150
getdat typ len
150151

151152
fromSizeM :: String -> Word32 -> Get Int
152-
fromSizeM label sz = maybe (fail label) pure (intFromW32 sz)
153-
where
154-
-- TODO: switch to @int-cast@ package
155-
intFromW32 :: Word32 -> Maybe Int
156-
intFromW32 w
157-
| intLargerThanWord32 = Just $! j
158-
| w > maxW = Nothing
159-
| otherwise = Just $! j
160-
where
161-
j = fromIntegral w
162-
intLargerThanWord32 = not (maxI < (0 :: Int))
163-
maxI = fromIntegral (maxBound :: Word32)
164-
maxW = fromIntegral (maxBound :: Int)
153+
fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz)

‎msgpack/src/Data/MessagePack/Integer.hs

+31-45
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import Control.Applicative
2020
import Control.DeepSeq (NFData (rnf))
2121
import Control.Exception (ArithException (DivideByZero, Overflow, Underflow),
2222
throw)
23+
import Data.IntCast
2324

2425
import Compat.Binary
2526
import Data.MessagePack.Tags
@@ -40,20 +41,20 @@ data MPInteger = MPInteger {- isW64 -} !Bool
4041

4142
-- NB: only valid if isW64 is true
4243
toW64 :: Int64 -> Word64
43-
toW64 = fromIntegral
44+
toW64 = intCastIso
4445

4546
class ToMPInteger a where
4647
toMPInteger :: a -> MPInteger
4748

48-
instance ToMPInteger Int8 where toMPInteger i = MPInteger False (fromIntegral i)
49-
instance ToMPInteger Int16 where toMPInteger i = MPInteger False (fromIntegral i)
50-
instance ToMPInteger Int32 where toMPInteger i = MPInteger False (fromIntegral i)
49+
instance ToMPInteger Int8 where toMPInteger i = MPInteger False (intCast i)
50+
instance ToMPInteger Int16 where toMPInteger i = MPInteger False (intCast i)
51+
instance ToMPInteger Int32 where toMPInteger i = MPInteger False (intCast i)
5152
instance ToMPInteger Int64 where toMPInteger = MPInteger False
52-
instance ToMPInteger Int where toMPInteger i = MPInteger False (fromIntegral i)
53+
instance ToMPInteger Int where toMPInteger i = MPInteger False (intCast i)
5354

54-
instance ToMPInteger Word8 where toMPInteger w = MPInteger False (fromIntegral w)
55-
instance ToMPInteger Word16 where toMPInteger w = MPInteger False (fromIntegral w)
56-
instance ToMPInteger Word32 where toMPInteger w = MPInteger False (fromIntegral w)
55+
instance ToMPInteger Word8 where toMPInteger w = MPInteger False (intCast w)
56+
instance ToMPInteger Word16 where toMPInteger w = MPInteger False (intCast w)
57+
instance ToMPInteger Word32 where toMPInteger w = MPInteger False (intCast w)
5758
instance ToMPInteger Word64 where toMPInteger w = MPInteger (i<0) i where i = fromIntegral w
5859
instance ToMPInteger Word where toMPInteger w = MPInteger (i<0) i where i = fromIntegral w
5960

@@ -67,61 +68,46 @@ class FromMPInteger a where
6768
fromMPInteger :: MPInteger -> Maybe a
6869

6970
instance FromMPInteger Word where
70-
fromMPInteger (MPInteger isW64 i)
71-
| 0 <= i || isW64
72-
, toW64 i <= maxW = Just $! fromIntegral i
73-
| otherwise = Nothing
74-
where
75-
maxW = fromIntegral (maxBound :: Word) :: Word64
71+
fromMPInteger (MPInteger True w) = intCastMaybe (toW64 w)
72+
fromMPInteger (MPInteger False i) = intCastMaybe i
7673

7774
instance FromMPInteger Word64 where
78-
fromMPInteger (MPInteger True w) = Just $! toW64 w
79-
fromMPInteger (MPInteger False i)
80-
| 0 <= i = Just (toW64 i)
81-
| otherwise = Nothing
75+
fromMPInteger (MPInteger True w) = Just $! toW64 w
76+
fromMPInteger (MPInteger False i) = intCastMaybe i
8277

8378
instance FromMPInteger Word32 where
8479
fromMPInteger (MPInteger True _) = Nothing
85-
fromMPInteger (MPInteger False i) = int64toInt i
80+
fromMPInteger (MPInteger False i) = intCastMaybe i
8681

8782
instance FromMPInteger Word16 where
8883
fromMPInteger (MPInteger True _) = Nothing
89-
fromMPInteger (MPInteger False i) = int64toInt i
84+
fromMPInteger (MPInteger False i) = intCastMaybe i
9085

9186
instance FromMPInteger Word8 where
9287
fromMPInteger (MPInteger True _) = Nothing
93-
fromMPInteger (MPInteger False i) = int64toInt i
88+
fromMPInteger (MPInteger False i) = intCastMaybe i
9489

9590
-----
9691

9792
instance FromMPInteger Int where
9893
fromMPInteger (MPInteger True _) = Nothing
99-
fromMPInteger (MPInteger False i) = int64toInt i
94+
fromMPInteger (MPInteger False i) = intCastMaybe i
10095

10196
instance FromMPInteger Int64 where
10297
fromMPInteger (MPInteger True _) = Nothing
10398
fromMPInteger (MPInteger False i) = Just i
10499

105100
instance FromMPInteger Int32 where
106101
fromMPInteger (MPInteger True _) = Nothing
107-
fromMPInteger (MPInteger False i) = int64toInt i
102+
fromMPInteger (MPInteger False i) = intCastMaybe i
108103

109104
instance FromMPInteger Int16 where
110105
fromMPInteger (MPInteger True _) = Nothing
111-
fromMPInteger (MPInteger False i) = int64toInt i
106+
fromMPInteger (MPInteger False i) = intCastMaybe i
112107

113108
instance FromMPInteger Int8 where
114109
fromMPInteger (MPInteger True _) = Nothing
115-
fromMPInteger (MPInteger False i) = int64toInt i
116-
117-
{-# INLINE int64toInt #-}
118-
int64toInt :: forall i . (Integral i, Bounded i) => Int64 -> Maybe i
119-
int64toInt i
120-
| minI <= i, i <= maxI = Just $! fromIntegral i
121-
| otherwise = Nothing
122-
where
123-
minI = fromIntegral (minBound :: i) :: Int64
124-
maxI = fromIntegral (maxBound :: i) :: Int64
110+
fromMPInteger (MPInteger False i) = intCastMaybe i
125111

126112
----------------------------------------------------------------------------
127113

@@ -246,20 +232,20 @@ putMPInteger :: MPInteger -> Put
246232
putMPInteger (MPInteger False i)
247233
-- positive fixnum stores 7-bit positive integer
248234
-- negative fixnum stores 5-bit negative integer
249-
| -32 <= i && i <= 127 = putWord8 (fromIntegral i)
235+
| -32 <= i && i <= 127 = putInt8 (fromIntegral i)
250236

251237
-- unsigned int encoding
252238
| i >= 0 = case () of
253239
_ | i < 0x100 -> putWord8 TAG_uint8 >> putWord8 (fromIntegral i)
254240
| i < 0x10000 -> putWord8 TAG_uint16 >> putWord16be (fromIntegral i)
255241
| i < 0x100000000 -> putWord8 TAG_uint32 >> putWord32be (fromIntegral i)
256-
| otherwise -> putWord8 TAG_uint64 >> putWord64be (fromIntegral i)
242+
| otherwise -> putWord8 TAG_uint64 >> putWord64be (intCastIso i) -- equivalent to 'putInt64be i'
257243

258244
-- signed int encoding
259-
| -0x80 <= i = putWord8 TAG_int8 >> putWord8 (fromIntegral i)
260-
| -0x8000 <= i = putWord8 TAG_int16 >> putWord16be (fromIntegral i)
261-
| -0x80000000 <= i = putWord8 TAG_int32 >> putWord32be (fromIntegral i)
262-
| otherwise = putWord8 TAG_int64 >> putWord64be (fromIntegral i)
245+
| -0x80 <= i = putWord8 TAG_int8 >> putInt8 (fromIntegral i)
246+
| -0x8000 <= i = putWord8 TAG_int16 >> putInt16be (fromIntegral i)
247+
| -0x80000000 <= i = putWord8 TAG_int32 >> putInt32be (fromIntegral i)
248+
| otherwise = putWord8 TAG_int64 >> putInt64be i
263249
putMPInteger (MPInteger True w) = putWord8 TAG_uint64 >> putWord64be (toW64 w)
264250

265251
-- | Deserializes 'MPInteger' from MessagePack
@@ -269,16 +255,16 @@ getMPInteger :: Get MPInteger
269255
getMPInteger = getWord8 >>= \case
270256
-- positive fixnum stores 7-bit positive integer
271257
-- negative fixnum stores 5-bit negative integer
272-
c | is_TAG_fixint c -> pure $! toMPInteger (fromIntegral c :: Int8)
258+
c | is_TAG_fixint c -> pure $! toMPInteger (intCastIso c :: Int8)
273259

274260
TAG_uint8 -> toMPInteger <$> getWord8
275261
TAG_uint16 -> toMPInteger <$> getWord16be
276262
TAG_uint32 -> toMPInteger <$> getWord32be
277263
TAG_uint64 -> toMPInteger <$> getWord64be
278264

279-
TAG_int8 -> toMPInteger <$> (fromIntegral <$> getWord8 :: Get Int8)
280-
TAG_int16 -> toMPInteger <$> (fromIntegral <$> getWord16be :: Get Int16)
281-
TAG_int32 -> toMPInteger <$> (fromIntegral <$> getWord32be :: Get Int32)
282-
TAG_int64 -> toMPInteger <$> (fromIntegral <$> getWord64be :: Get Int64)
265+
TAG_int8 -> toMPInteger <$> getInt8
266+
TAG_int16 -> toMPInteger <$> getInt16be
267+
TAG_int32 -> toMPInteger <$> getInt32be
268+
TAG_int64 -> toMPInteger <$> getInt64be
283269

284270
_ -> empty

‎msgpack/src/Data/MessagePack/Put.hs

+2-11
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Data.MessagePack.Put (
2020
import Control.Applicative
2121
import Data.Bits
2222
import qualified Data.ByteString as S
23+
import Data.IntCast
2324
import qualified Data.Text as T
2425
import qualified Data.Text.Encoding as T
2526
import qualified Data.Vector as V
@@ -121,14 +122,4 @@ putExt' typ (sz,putdat) = do
121122
----------------------------------------------------------------------------
122123

123124
toSizeM :: String -> Int -> PutM Word32
124-
toSizeM label len0 = maybe (fail label) pure (int2w32 len0)
125-
where
126-
-- TODO: switch to @int-cast@ package
127-
int2w32 :: Int -> Maybe Word32
128-
int2w32 j
129-
| j < 0 = Nothing
130-
| intLargerThanWord32, j > maxI = Nothing
131-
| otherwise = Just $! fromIntegral j
132-
where
133-
intLargerThanWord32 = not (maxI < (0 `asTypeOf` j))
134-
maxI = fromIntegral (maxBound :: Word32)
125+
toSizeM label len0 = maybe (fail label) pure (intCastMaybe len0)

0 commit comments

Comments
 (0)