diff --git a/.github/workflows/haskell-ci.yaml b/.github/workflows/haskell-ci.yaml index cae3f2b..be3e122 100644 --- a/.github/workflows/haskell-ci.yaml +++ b/.github/workflows/haskell-ci.yaml @@ -5,7 +5,7 @@ on: - pull_request jobs: - build: + ghc: runs-on: ubuntu-latest strategy: fail-fast: false @@ -39,7 +39,7 @@ jobs: - name: Haddock run: cabal haddock - build-i386: + ghc-i386: runs-on: ubuntu-latest container: image: i386/ubuntu @@ -59,3 +59,24 @@ jobs: run: cabal build - name: Test run: cabal test --enable-tests + + mhs: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v6 + with: + path: binary + - name: Checkout MicroHs repository + uses: actions/checkout@v6 + with: + repository: augustss/MicroHs + path: mhs + - name: Install MicroHs + run: | + cd mhs + make minstall + echo "$HOME/.mcabal/bin" >> $GITHUB_PATH + - name: Install binary + run: | + cd binary + mcabal -r install diff --git a/.gitignore b/.gitignore index 2ef3f92..f10dfa6 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ GNUmakefile dist-boot dist-install +dist-mcabal dist-newstyle ghc.mk .cabal-sandbox diff --git a/README.md b/README.md index eece40c..6f650a7 100644 --- a/README.md +++ b/README.md @@ -6,23 +6,18 @@ The ``binary`` package provides Data.Binary, containing the Binary class, and associated methods, for serialising values to and from lazy -ByteStrings. -A key feature of ``binary`` is that the interface is both pure, and +ByteStrings. +A key feature of ``binary`` is that the interface is both pure, and moderately efficient. -The ``binary`` package is portable to GHC and Hugs. +The ``binary`` package is portable to GHC and MicroHs. ## Installing binary from Hackage ## ``binary`` is part of The Glasgow Haskell Compiler (GHC) and therefore if you -have either GHC or [The Haskell Platform](http://www.haskell.org/platform/) -installed, you already have ``binary``. +have GHC installed, you already have ``binary``. More recent versions of ``binary`` than you might have installed may be -available. You can use ``cabal-install`` to install a later version from -[Hackage](http://hackage.haskell.org/package/binary). - - $ cabal update - $ cabal install binary +available from [Hackage](https://hackage.haskell.org/package/binary). ## Building binary ## diff --git a/binary.cabal b/binary.cabal index 5f305ed..382222c 100644 --- a/binary.cabal +++ b/binary.cabal @@ -43,15 +43,15 @@ source-repository head library build-depends: base >= 4.9 && < 5, bytestring >= 0.10.4, containers, array hs-source-dirs: src - exposed-modules: Data.Binary, - Data.Binary.Put, - Data.Binary.Get, - Data.Binary.Get.Internal, + exposed-modules: Data.Binary + Data.Binary.Put + Data.Binary.Get + Data.Binary.Get.Internal Data.Binary.Builder - other-modules: Data.Binary.Class, - Data.Binary.Internal, - Data.Binary.Generic, + other-modules: Data.Binary.Class + Data.Binary.Internal + Data.Binary.Generic Data.Binary.FloatCast ghc-options: -O2 -Wall -fliberate-case-threshold=1000 diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs index 7f25db5..3c45ba8 100644 --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -88,12 +88,15 @@ import Control.Monad import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L +#ifdef __GLASGOW_HASKELL__ import qualified Data.ByteString.Builder.Prim as Prim +#endif import Data.List (unfoldr) +import qualified Data.List as List -- And needed for the instances: -#if MIN_VERSION_base(4,10,0) +#if defined(__GLASGOW_HASKELL__) && MIN_VERSION_base(4,10,0) import Type.Reflection import Type.Reflection.Unsafe import Data.Kind (Type) @@ -182,7 +185,7 @@ class Binary t where {-# INLINE defaultPutList #-} defaultPutList :: Binary a => [a] -> Put -defaultPutList xs = put (length xs) <> mapM_ put xs +defaultPutList xs = put (List.length xs) <> mapM_ put xs #ifdef HAS_GENERICALLY instance (Generic a, GBinaryPut (Rep a), GBinaryGet (Rep a)) => Binary (Generically a) where @@ -241,73 +244,89 @@ instance Binary Ordering where -- Words8s are written as bytes instance Binary Word8 where put = putWord8 +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.word8 xs) +#endif get = getWord8 -- Words16s are written as 2 bytes in big-endian (network) order instance Binary Word16 where put = putWord16be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.word16BE xs) +#endif get = getWord16be -- Words32s are written as 4 bytes in big-endian (network) order instance Binary Word32 where put = putWord32be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.word32BE xs) +#endif get = getWord32be -- Words64s are written as 8 bytes in big-endian (network) order instance Binary Word64 where put = putWord64be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.word64BE xs) +#endif get = getWord64be -- Int8s are written as a single byte. instance Binary Int8 where put = putInt8 +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.int8 xs) +#endif get = getInt8 -- Int16s are written as a 2 bytes in big endian format instance Binary Int16 where put = putInt16be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.int16BE xs) +#endif get = getInt16be -- Int32s are written as a 4 bytes in big endian format instance Binary Int32 where put = putInt32be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.int32BE xs) +#endif get = getInt32be -- Int64s are written as a 8 bytes in big endian format instance Binary Int64 where put = putInt64be +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.int64BE xs) +#endif get = getInt64be ------------------------------------------------------------------------ @@ -315,19 +334,23 @@ instance Binary Int64 where -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Binary Word where put = putWord64be . fromIntegral +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs)) +#endif get = liftM fromIntegral getWord64be -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Binary Int where put = putInt64be . fromIntegral +#ifdef __GLASGOW_HASKELL__ {-# INLINE putList #-} putList xs = put (length xs) <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs)) +#endif get = liftM fromIntegral getInt64be ------------------------------------------------------------------------ @@ -347,7 +370,11 @@ instance Binary Integer where {-# INLINE put #-} put n | n >= lo && n <= hi = +#ifdef __GLASGOW_HASKELL__ putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n)) +#else + putWord8 0 <> putInt32be (fromIntegral n) +#endif where lo = fromIntegral (minBound :: SmallInt) :: Integer hi = fromIntegral (maxBound :: SmallInt) :: Integer @@ -502,7 +529,7 @@ instance Binary a => Binary (Complex a) where -- Char is serialised as UTF-8 instance Binary Char where put = putCharUtf8 - putList str = put (length str) <> putStringUtf8 str + putList str = put (List.length str) <> putStringUtf8 str get = do let getByte = liftM (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int @@ -842,7 +869,7 @@ instance Binary a => Binary (Semigroup.Last a) where get = fmap Semigroup.Last get put = put . Semigroup.getLast -#if __GLASGOW_HASKELL__ < 901 +#if !MIN_VERSION_base(4,15,0) -- | @since 0.8.4.0 instance Binary a => Binary (Semigroup.Option a) where get = fmap Semigroup.Option get @@ -875,7 +902,7 @@ instance Binary a => Binary (NE.NonEmpty a) where ------------------------------------------------------------------------ -- Typeable/Reflection -#if MIN_VERSION_base(4,10,0) +#if defined(__GLASGOW_HASKELL__) && MIN_VERSION_base(4,10,0) -- $typeable-instances -- diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs index b497ba2..7404836 100644 --- a/src/Data/Binary/FloatCast.hs +++ b/src/Data/Binary/FloatCast.hs @@ -20,7 +20,23 @@ module Data.Binary.FloatCast #if MIN_VERSION_base(4,11,0) import Data.Word (Word32, Word64) +#if defined(__GLASGOW_HASKELL__) import GHC.Float (castWord32ToFloat, castFloatToWord32, castWord64ToDouble, castDoubleToWord64) +#elif defined(__MHS__) +import Primitives (primUnsafeCoerce, primWordToFloatRaw, primWordFromFloatRaw, primWord64ToDoubleRaw, primWord64FromDoubleRaw) + +castWord32ToFloat :: Word32 -> Float +castWord32ToFloat = primWordToFloatRaw . primUnsafeCoerce + +castFloatToWord32 :: Float -> Word32 +castFloatToWord32 = primUnsafeCoerce . primWordFromFloatRaw + +castWord64ToDouble :: Word64 -> Double +castWord64ToDouble = primWord64ToDoubleRaw + +castDoubleToWord64 :: Double -> Word64 +castDoubleToWord64 = primWord64FromDoubleRaw +#endif floatToWord :: Float -> Word32 floatToWord = castFloatToWord32 diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs index 5e28ffb..a096e61 100644 --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -3,10 +3,6 @@ {-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ >= 800 -#define HAS_DATA_KIND -#endif - ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Generic @@ -34,9 +30,7 @@ import Data.Proxy #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -#ifdef HAS_DATA_KIND -import Data.Kind -#endif +import Data.Kind (Type) import GHC.Generics import Prelude -- Silence AMP warning. @@ -151,11 +145,7 @@ instance GBinaryPut a => GSumPut (C1 c a) where class SumSize f where sumSize :: Tagged f Word64 -#ifdef HAS_DATA_KIND newtype Tagged (s :: Type -> Type) b = Tagged {unTagged :: b} -#else -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} -#endif instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs index a0b57da..968aae9 100644 --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -469,7 +469,7 @@ getInt8 = fromIntegral <$> getWord8 -- force GHC to inline getWordXX {-# RULES "getWord8/readN" getWord8 = readN 1 B.unsafeHead -#-} + #-} -- | Read a Word16 in big endian format getWord16be :: Get Word16 diff --git a/src/Data/Binary/Internal.hs b/src/Data/Binary/Internal.hs index d04b728..3e47bed 100644 --- a/src/Data/Binary/Internal.hs +++ b/src/Data/Binary/Internal.hs @@ -1,9 +1,14 @@ {-# LANGUAGE CPP #-} -module Data.Binary.Internal +module Data.Binary.Internal ( accursedUnutterablePerformIO ) where -#if MIN_VERSION_bytestring(0,10,6) +#if defined(__MHS__) +import Primitives (primPerformIO) + +accursedUnutterablePerformIO :: IO a -> a +accursedUnutterablePerformIO = primPerformIO +#elif MIN_VERSION_bytestring(0,10,6) import Data.ByteString.Internal( accursedUnutterablePerformIO ) #else import Data.ByteString.Internal( inlinePerformIO )