|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | + |
| 3 | +-- | Compat layer for "Data.Binary" |
| 4 | +-- |
| 5 | +-- Supports @binary-0.7.1@ and later |
| 6 | +module Compat.Binary |
| 7 | + ( Binary(put, get) |
| 8 | + |
| 9 | + , runPut', runPut, PutM, Put |
| 10 | + , runGet', runGet, Get |
| 11 | + |
| 12 | + , getWord64be, putWord64be |
| 13 | + , getWord32be, putWord32be |
| 14 | + , getWord16be, putWord16be |
| 15 | + , getWord8 , putWord8 |
| 16 | + |
| 17 | + , getFloat32be, putFloat32be |
| 18 | + , getFloat64be, putFloat64be |
| 19 | + |
| 20 | + , getByteString, putByteString |
| 21 | + |
| 22 | + -- convenience |
| 23 | + , Data.Word.Word, Word8, Word16, Word32, Word64 |
| 24 | + , Data.Int.Int, Int8, Int16, Int32, Int64 |
| 25 | + ) where |
| 26 | + |
| 27 | +import qualified Data.ByteString as BS |
| 28 | +import qualified Data.ByteString.Lazy as BL |
| 29 | + |
| 30 | +import Data.Array.ST (MArray, STUArray, newArray, readArray) |
| 31 | +import Data.Array.Unsafe (castSTUArray) |
| 32 | +import Data.Binary |
| 33 | +import Data.Binary.Get |
| 34 | +import Data.Binary.Put |
| 35 | +import Data.Int |
| 36 | +import Data.Word |
| 37 | +import GHC.ST (ST, runST) |
| 38 | + |
| 39 | + |
| 40 | +runGet' :: BS.ByteString -> Get a -> Maybe a |
| 41 | +runGet' bs0 g = case pushEndOfInput (runGetIncremental g `pushChunk` bs0) of |
| 42 | + Done bs _ x |
| 43 | + | BS.null bs -> return x |
| 44 | + | otherwise -> fail "trailing data" |
| 45 | + Partial _ -> fail "eof" |
| 46 | + Fail _ _ msg -> fail msg |
| 47 | + |
| 48 | +runPut' :: Put -> BS.ByteString |
| 49 | +runPut' = BL.toStrict . runPut |
| 50 | + |
| 51 | + |
| 52 | +-- NB: Once we drop support for binary < 0.8.4 we can use @binary@'s own {get,put}{Double,Float}be operations |
| 53 | + |
| 54 | +putFloat32be :: Float -> Put |
| 55 | +putFloat32be x = putWord32be (runST (cast x)) |
| 56 | + |
| 57 | +putFloat64be :: Double -> Put |
| 58 | +putFloat64be x = putWord64be (runST (cast x)) |
| 59 | + |
| 60 | +getFloat32be :: Get Float |
| 61 | +getFloat32be = do |
| 62 | + x <- getWord32be |
| 63 | + return (runST (cast x)) |
| 64 | + |
| 65 | +getFloat64be :: Get Double |
| 66 | +getFloat64be = do |
| 67 | + x <- getWord64be |
| 68 | + return (runST (cast x)) |
| 69 | + |
| 70 | +-- See https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa/7002812#7002812 |
| 71 | + |
| 72 | +{-# INLINE cast #-} |
| 73 | +cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b |
| 74 | +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 |
0 commit comments