diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,38 +1,34 @@ -- 0.1.8.0 - - `ZonedTime` instance (by @mstksg) +# 1.0.6 -- 0.1.7.0 - - GHC-8.2 support - - `SystemTime` instance (`time-1.8`) +- Use automatic flags for compatibility conditionals -- 0.1.6.0 - - Add instance for `hashed` in `hashable >=1.2.5.0` +# 1.0.5 -- 0.1.5.2 - - Fix issue with binary-0.5.* +- Support GHC-8.6.5..GHC-9.10.1 -- 0.1.5.1 - - Fix issue with binary-0.8.4.* and GHC-7.* +# 1.0.4.1 -- 0.1.5.0 - - Add `CI a` instance - - Add `Alt f a` instance for `base >= 4.8.0.0` - - Add `WrappedMonoid m` and `Arg a b` instances - - Support `binary-0.8.4.0` - - Add `Void` instance (`base <4.8`) - - Add `Natural` instance (`nats <1.1`, `base <4.8`) +- Support OneTuple-0.4 -- 0.1.4.0 - - Add `AbsoluteTime` instance (thanks @neongreen) +# 1.0.4 -- 0.1.3.1 - - Support GHC 7.6 +- Depend on `data-byte-array` to provide `Data.Array.Byte` instance -- 0.1.3.0 - - Add `Min`, `Max`, `First`, `Last`, `Option`, and `NonEmpty` instances (from `semigroups`) +# 1.0.3 -- 0.1.2.0 - - Support `scientific >= 0.3.4` +- Add `ByteArray` (from `Data.Array.Byte` instance) -- 0.1.1.0 - - Add `Dual`, `All`, `Any`, `Sum`, `Product`, `First` and `Last` instances +# 1.0.2 + +- Add `Solo` instance + +# 1.0.1 + +- Fix `MonadFail` instances shim +- `NonEmpty` doesn't fail on empty list + +# 1 + +Stripped down the package to only shim `binary` orphans. + +For more instances check [binary-instances](https://hackage.haskell.org/package/binary-instances) package. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,28 @@ -Copyright (c) 2015, Oleg Grenrus +Copyright © 2019 @binary@-contributors, Oleg Grenrus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. - * Neither the name of Oleg Grenrus nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +* Neither the name Mark Karpov nor the names of contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,6 +0,0 @@ -# binary-orphans - -[![Build Status](https://travis-ci.org/phadej/binary-orphans.svg?branch=master)](https://travis-ci.org/phadej/binary-orphans) -[![Hackage](https://img.shields.io/hackage/v/binary-orphans.svg)](http://hackage.haskell.org/package/binary-orphans) - -Orphan instances for [binary](http://hackage.haskell.org/package/binary). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/binary-orphans.cabal b/binary-orphans.cabal --- a/binary-orphans.cabal +++ b/binary-orphans.cabal @@ -1,83 +1,90 @@ -name: binary-orphans -version: 0.1.8.0 -synopsis: Orphan instances for binary -description: `binary-orphans` defines orphan instances for types in some popular packages. -category: Web -homepage: https://github.com/phadej/binary-orphans#readme -bug-reports: https://github.com/phadej/binary-orphans/issues -author: Oleg Grenrus -maintainer: Oleg Grenrus -license: BSD3 -license-file: LICENSE -tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 -build-type: Simple -cabal-version: >= 1.10 +cabal-version: 1.12 +name: binary-orphans +version: 1.0.6 +synopsis: Compatibility package for binary; provides instances +category: Data, Binary, Parsing, Compatibility +description: + This package provides instances defined in later versions of @binary@ package + . + Prior version 1 this packages provided instances for other packages. + That functionality is moved to [binary-instances](https://hackage.haskell.org/package/binary-instances) package. -extra-source-files: - CHANGELOG.md - README.md +build-type: Simple +maintainer: Oleg Grenrus +author: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: + GHC ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.6 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 +extra-source-files: CHANGELOG.md + source-repository head - type: git - location: https://github.com/phadej/binary-orphans + type: git + location: https://github.com/phadej/binary-orphans.git +flag base-ge-4-16 + description: @base >=4.16@ (GHC-9.2) + default: True + manual: False + +flag base-ge-4-17 + description: @base >=4.17@ (GHC-9.4) + default: True + manual: False + library - hs-source-dirs: - src - ghc-options: -Wall -fno-warn-orphans - build-depends: - base >=4.6.0.1 && <4.11 - , aeson >=0.7.0.6 && <1.3 - , binary >=0.5.1.1 && <0.8.6 || ==0.9.0.0 - , case-insensitive >=1.2.0.4 && <1.2.1 - , hashable >=1.2.3.3 && <1.3 - , scientific >=0.3.3.8 && <0.4 - , tagged >=0.7.3 && <0.8.6 - , text >=1.2.0.6 && <1.3 - , time >=1.4.0.1 && <1.9 - , unordered-containers >=0.2.5.1 && <0.3 - , vector >=0.10.12.3 && <0.13 - , text-binary >=0.1.0 && <0.3 - , vector-binary-instances >=0.2.1.0 && <0.3 - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.16.2.2 && <0.18.4 - if !impl(ghc >= 7.10) - build-depends: - void >=0.7 && <0.8 - , nats >=1 && <1.2 - exposed-modules: - Data.Binary.Orphans default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Data.Binary.Orphans + other-extensions: CPP + build-depends: + base >=4.12.0.0 && <4.23 + , binary >=0.8.6.0 && <0.8.10 + if !flag(base-ge-4-16) + build-depends: OneTuple >=0.4.2 && <0.5 + + if !flag(base-ge-4-17) + build-depends: data-array-byte >=0.1.0.1 && <0.2 + + if flag(base-ge-4-16) + build-depends: base >=4.16 + + else + build-depends: base <4.16 + + if flag(base-ge-4-17) + build-depends: base >=4.17 + + else + build-depends: base <4.17 + test-suite binary-orphans-test - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: - test - ghc-options: -Wall -fno-warn-orphans + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + ghc-options: -Wall build-depends: base - , aeson , binary - , case-insensitive - , hashable - , scientific - , tagged - , text - , time - , unordered-containers - , vector , binary-orphans - , QuickCheck >=2.10 && <2.11 - , quickcheck-instances >=0.3.16 && <0.4 - , tasty >=0.10.1.2 && <0.12 - , tasty-quickcheck >=0.8.3.2 && <0.10 - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.16.2.2 && <0.18.3 - if !impl(ghc >= 7.10) - build-depends: - void >=0.7 && <0.8 - , nats >=1 && <1.2 - default-language: Haskell2010 + , QuickCheck >=2.13.1 && <2.19 + , quickcheck-instances >=0.3.28 && <0.5 + , tasty >=0.10.1.2 && <1.6 + , tasty-quickcheck >=0.8.3.2 && <0.12 + + if !flag(base-ge-4-17) + build-depends: data-array-byte diff --git a/src/Data/Binary/Orphans.hs b/src/Data/Binary/Orphans.hs --- a/src/Data/Binary/Orphans.hs +++ b/src/Data/Binary/Orphans.hs @@ -1,340 +1,92 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -#if MIN_VERSION_base(4,7,0) -#define HAS_FIXED_CONSTRUCTOR -#endif -#ifndef HAS_FIXED_CONSTRUCTOR +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Orphans --- Copyright : (C) 2015 Oleg Grenrus --- License : BSD3 --- Maintainer : Oleg Grenrus --- --- Provides orphan 'Binary' instances for types in various packages: --- --- * aeson --- * scientific (prior to scientific-0.3.4.0) --- * semigroups --- * tagged --- * text (through text-binary, or text >= 1.2.1) --- * time --- * unordered-containers --- * vector (through vector-binary-instances) --- --- Also there is @'Binary' 'Fixed'@ instance. -module Data.Binary.Orphans ( - -- * Class re-export - Binary(..), - -- * Module re-export - module Data.Binary, - ) where - -import Control.Monad (liftM, liftM2, liftM3) -import qualified Data.Aeson as A -import Data.Bits -import Data.Binary -import qualified Data.CaseInsensitive as CI -import qualified Data.Fixed as Fixed -import qualified Data.HashMap.Lazy as HM -import qualified Data.HashSet as HS -import qualified Data.Hashable as Hashable -import Data.List (unfoldr, foldl') -import qualified Data.List.NonEmpty as NE -import qualified Data.Monoid as Monoid -import qualified Data.Semigroup as Semigroup -import qualified Data.Tagged as Tagged -import qualified Data.Time as Time -import qualified Data.Time.Clock.TAI as Time -import qualified Data.Void as Void -import Numeric.Natural - --- From other packages -#if !(MIN_VERSION_text(1,2,1)) -import Data.Text.Binary () -#endif -import Data.Vector.Binary () - -#if !(MIN_VERSION_scientific(0,3,4)) -import qualified Data.Scientific as S -#endif - -#if MIN_VERSION_time(1,8,0) -import qualified Data.Time.Clock.System as Time -#endif - -instance Binary A.Value where - get = do - t <- get :: Get Int - case t of - 0 -> fmap A.Object get - 1 -> fmap A.Array get - 2 -> fmap A.String get - 3 -> fmap A.Number get - 4 -> fmap A.Bool get - 5 -> return A.Null - _ -> fail $ "Invalid Value tag: " ++ show t - - put (A.Object v) = put (0 :: Int) >> put v - put (A.Array v) = put (1 :: Int) >> put v - put (A.String v) = put (2 :: Int) >> put v - put (A.Number v) = put (3 :: Int) >> put v - put (A.Bool v) = put (4 :: Int) >> put v - put A.Null = put (5 :: Int) - - -instance (Hashable.Hashable k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where - get = fmap HM.fromList get - put = put . HM.toList - -instance (Hashable.Hashable v, Eq v, Binary v) => Binary (HS.HashSet v) where - get = fmap HS.fromList get - put = put . HS.toList - -#if MIN_VERSION_hashable(1,2,5) -instance (Hashable.Hashable a, Binary a) => Binary (Hashable.Hashed a) where - get = fmap Hashable.hashed get - put = put . Hashable.unhashed -#endif +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Data.Binary.Orphans () where -#if !(MIN_VERSION_scientific(0,3,4)) -instance Binary S.Scientific where - get = liftM2 S.scientific get get - put s = put (S.coefficient s) >> put (S.base10Exponent s) -#endif +import Data.Binary -instance Binary b => Binary (Tagged.Tagged s b) where - put = put . Tagged.unTagged - get = fmap Tagged.Tagged get +import Control.Monad (replicateM) -#if !MIN_VERSION_binary(0,8,0) -#ifdef HAS_FIXED_CONSTRUCTOR -instance Binary (Fixed.Fixed a) where - put (Fixed.MkFixed a) = put a - get = Fixed.MkFixed `liftM` get +#if MIN_VERSION_base(4,18,0) +import Data.Tuple (Solo (MkSolo)) +#elif MIN_VERSION_base(4,16,0) +import Data.Tuple (Solo (Solo)) +#define MkSolo Solo #else -instance Fixed.HasResolution a => Binary (Fixed.Fixed a) where - -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7 - put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer) - get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get -#endif -#endif - -------------------------------------------------------------------------------- --- time -------------------------------------------------------------------------------- - -instance Binary Time.Day where - get = fmap Time.ModifiedJulianDay get - put = put . Time.toModifiedJulianDay - -instance Binary Time.UniversalTime where - get = fmap Time.ModJulianDate get - put = put . Time.getModJulianDate - -instance Binary Time.DiffTime where - get = fmap Time.picosecondsToDiffTime get - put = (put :: Fixed.Pico -> Put) . realToFrac - -instance Binary Time.UTCTime where - get = liftM2 Time.UTCTime get get - put (Time.UTCTime d dt) = put d >> put dt - -instance Binary Time.NominalDiffTime where - get = fmap realToFrac (get :: Get Fixed.Pico) - put = (put :: Fixed.Pico -> Put) . realToFrac - -instance Binary Time.TimeZone where - get = liftM3 Time.TimeZone get get get - put (Time.TimeZone m s n) = put m >> put s >> put n - -instance Binary Time.TimeOfDay where - get = liftM3 Time.TimeOfDay get get get - put (Time.TimeOfDay h m s) = put h >> put m >> put s - -instance Binary Time.LocalTime where - get = liftM2 Time.LocalTime get get - put (Time.LocalTime d tod) = put d >> put tod - --- | /Since: binary-orphans-0.1.8.0/ -instance Binary Time.ZonedTime where - get = liftM2 Time.ZonedTime get get - put (Time.ZonedTime t z) = put t >> put z - --- | /Since: binary-orphans-0.1.4.0/ -instance Binary Time.AbsoluteTime where - get = fmap (flip Time.addAbsoluteTime Time.taiEpoch) get - put = put . flip Time.diffAbsoluteTime Time.taiEpoch - -#if MIN_VERSION_time(1,8,0) --- | /Since: binary-orphans-0.1.7.0/ -instance Binary Time.SystemTime where - get = liftM2 Time.MkSystemTime get get - put (Time.MkSystemTime s ns) = put s >> put ns -#endif - -#if !MIN_VERSION_binary(0,8,4) - -------------------------------------------------------------------------------- --- Monoid -------------------------------------------------------------------------------- - --- | @since 0.1.1.0 -instance Binary a => Binary (Monoid.Dual a) where - get = fmap Monoid.Dual get - put = put . Monoid.getDual - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary Monoid.All where - get = fmap Monoid.All get - put = put . Monoid.getAll - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary Monoid.Any where - get = fmap Monoid.Any get - put = put . Monoid.getAny - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary a => Binary (Monoid.Sum a) where - get = fmap Monoid.Sum get - put = put . Monoid.getSum - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary a => Binary (Monoid.Product a) where - get = fmap Monoid.Product get - put = put . Monoid.getProduct - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary a => Binary (Monoid.First a) where - get = fmap Monoid.First get - put = put . Monoid.getFirst - --- | /Since: binary-orphans-0.1.1.0/ -instance Binary a => Binary (Monoid.Last a) where - get = fmap Monoid.Last get - put = put . Monoid.getLast - -#if MIN_VERSION_base(4,8,0) --- | /Since: binary-orphans-0.1.5.0/ -instance Binary (f a) => Binary (Monoid.Alt f a) where - get = fmap Monoid.Alt get - put = put . Monoid.getAlt -#endif +import Data.Tuple.Solo (Solo (MkSolo)) #endif -------------------------------------------------------------------------------- --- semigroups -------------------------------------------------------------------------------- - -#if !MIN_VERSION_binary(0,8,4) || !MIN_VERSION_base(4,9,0) --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (Semigroup.Min a) where - get = fmap Semigroup.Min get - put = put . Semigroup.getMin - --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (Semigroup.Max a) where - get = fmap Semigroup.Max get - put = put . Semigroup.getMax - --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (Semigroup.First a) where - get = fmap Semigroup.First get - put = put . Semigroup.getFirst - --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (Semigroup.Last a) where - get = fmap Semigroup.Last get - put = put . Semigroup.getLast - --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (Semigroup.Option a) where - get = fmap Semigroup.Option get - put = put . Semigroup.getOption - --- | /Since: binary-orphans-0.1.3.0/ -instance Binary a => Binary (NE.NonEmpty a) where - get = fmap NE.fromList get - put = put . NE.toList - --- | /Since: binary-orphans-0.1.5.0/ -instance Binary m => Binary (Semigroup.WrappedMonoid m) where - get = fmap Semigroup.WrapMonoid get - put = put . Semigroup.unwrapMonoid - --- | /Since: binary-orphans-0.1.5.0/ -instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where - get = liftM2 Semigroup.Arg get get - put (Semigroup.Arg a b) = put a >> put b -#endif +import Data.Array.Byte (ByteArray (..), MutableByteArray (..)) +import GHC.Exts + (Int (..), indexWord8Array#, newByteArray#, sizeofByteArray#, + unsafeFreezeByteArray#, writeWord8Array#) +import GHC.ST (ST (..), runST) +import GHC.Word (Word8 (..)) ------------------------------------------------------------------------------- --- case-insensitive +-- future-binary ------------------------------------------------------------------------------- --- | /Since: binary-orphans-0.1.5.0/ -instance (CI.FoldCase a, Binary a) => Binary (CI.CI a) where - get = fmap CI.mk get - put = put . CI.foldedCase - -------------------------------------------------------------------------------- --- void -------------------------------------------------------------------------------- +-- | @since 1.0.2 +instance Binary a => Binary (Solo a) where + put (MkSolo x) = put x + get = fmap MkSolo get -#if !MIN_VERSION_binary(0,8,0) -instance Binary Void.Void where - put = Void.absurd - get = fail "Binary.get @Void" -#endif +-- | @since 1.0.3 +instance Binary ByteArray where + put ba = put maxI >> go 0 + where + maxI :: Int + maxI = sizeofByteArray ba -------------------------------------------------------------------------------- --- nats -------------------------------------------------------------------------------- + go :: Int -> Put + go i | i < maxI = put (indexByteArray ba i) >> go (i + 1) + | otherwise = return () -#ifndef MIN_VERSION_nats -#define MIN_VERSION_nats(x,y,z) 0 -#endif + get = do + len <- get + xs <- replicateM len get + return (byteArrayFromListN len xs) -#if !MIN_VERSION_binary(0,7,3) && !MIN_VERSION_nats(1,1,0) --- Fixed-size type for a subset of Natural -type NaturalWord = Word64 +{-# INLINE sizeofByteArray #-} +sizeofByteArray :: ByteArray -> Int +sizeofByteArray (ByteArray ba) = I# (sizeofByteArray# ba) --- | /Since: 0.7.3.0/ -instance Binary Natural where - {-# INLINE put #-} - put n | n <= hi = - putWord8 0 - >> put (fromIntegral n :: NaturalWord) -- fast path - where - hi = fromIntegral (maxBound :: NaturalWord) :: Natural +{-# INLINE indexByteArray #-} +indexByteArray :: ByteArray -> Int -> Word8 +indexByteArray (ByteArray ba) (I# i) = W8# (indexWord8Array# ba i) - put n = - putWord8 1 - >> put (unroll (abs n)) -- unroll the bytes +{-# INLINE byteArrayFromListN #-} +byteArrayFromListN :: Int -> [Word8] -> ByteArray +byteArrayFromListN len xs = runST $ do + mba <- newByteArray len + go mba 0 xs + unsafeFreezeByteArray mba + where + go :: MutableByteArray s -> Int -> [Word8] -> ST s () + go mba i ys + | i < len = case ys of + [] -> writeWord8Array mba i 0 >> go mba (i + 1) ys + z:zs -> writeWord8Array mba i z >> go mba (i + 1) zs - {-# INLINE get #-} - get = do - tag <- get :: Get Word8 - case tag of - 0 -> liftM fromIntegral (get :: Get NaturalWord) - _ -> do bytes <- get - return $! roll bytes + | otherwise = return () +{-# INLINE newByteArray #-} +newByteArray :: Int -> ST s (MutableByteArray s) +newByteArray (I# len) = ST $ \s -> case newByteArray# len s of + (# s', mba #) -> (# s', MutableByteArray mba #) --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: (Integral a, Bits a) => a -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) +{-# INLINE unsafeFreezeByteArray #-} +unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray +unsafeFreezeByteArray (MutableByteArray mba) = ST $ \s -> case unsafeFreezeByteArray# mba s of + (# s', ba #) -> (# s', ByteArray ba #) -roll :: (Integral a, Bits a) => [Word8] -> a -roll = foldl' unstep 0 . reverse - where - unstep a b = a `shiftL` 8 .|. fromIntegral b -#endif +{-# INLINE writeWord8Array #-} +writeWord8Array :: MutableByteArray s -> Int -> Word8 -> ST s () +writeWord8Array (MutableByteArray mba) (I# i) (W8# w) = ST $ \s -> case writeWord8Array# mba i w s of + s' -> (# s', () #) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,43 +1,28 @@ -{-# LANGUAGE CPP #-} module Main (main) where -import Data.Binary +import Data.Array.Byte (ByteArray) +import Data.Binary (Binary, decode, encode) import Data.Binary.Orphans () -import Data.Proxy +import Data.Monoid (Sum) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Min (..)) +-- import Data.Tuple.Solo (Solo (..)) +import Numeric.Natural (Natural) +import Test.QuickCheck (Property, (===)) import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.QuickCheck as QC - -import Data.HashMap.Lazy (HashMap) -import Data.HashSet (HashSet) -import Data.Time (UTCTime, Day, DiffTime, NominalDiffTime, TimeZone, TimeOfDay, LocalTime) -import Data.Time.Clock.TAI (AbsoluteTime) -import Data.Monoid (Sum) -import Data.Text (Text) -import Data.CaseInsensitive (CI) -import Data.Monoid (Sum(..)) -import Data.Semigroup (Min(..)) - -import qualified Data.CaseInsensitive as CI +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) main :: IO () main = defaultMain tests tests :: TestTree tests = testGroup "Roundtrip" - [ QC.testProperty "HashMap" $ roundtrip (Proxy :: Proxy (HashMap Int String)) - , QC.testProperty "HashSet" $ roundtrip (Proxy :: Proxy (HashSet Int)) - , QC.testProperty "UTCTime" $ roundtrip (Proxy :: Proxy UTCTime) - , QC.testProperty "Day" $ roundtrip (Proxy :: Proxy Day) - , QC.testProperty "DiffTime" $ roundtrip (Proxy :: Proxy DiffTime) - , QC.testProperty "NominalDiffTime" $ roundtrip (Proxy :: Proxy NominalDiffTime) - , QC.testProperty "TimeZone" $ roundtrip (Proxy :: Proxy TimeZone) - , QC.testProperty "TimeOfDay" $ roundtrip (Proxy :: Proxy TimeOfDay) - , QC.testProperty "LocalTime" $ roundtrip (Proxy :: Proxy LocalTime) - , QC.testProperty "AbsoluteTime" $ roundtrip (Proxy :: Proxy AbsoluteTime) - , QC.testProperty "CI Text" $ roundtrip (Proxy :: Proxy (CI Text)) - , QC.testProperty "Sum Int" $ roundtrip (Proxy :: Proxy (Sum Int)) - , QC.testProperty "Min Int" $ roundtrip (Proxy :: Proxy (Min Int)) + [ testProperty "Natural" $ roundtrip (Proxy :: Proxy Natural) + , testProperty "Sum Int" $ roundtrip (Proxy :: Proxy (Sum Int)) + , testProperty "Min Int" $ roundtrip (Proxy :: Proxy (Min Int)) + -- , testProperty "Solo Int" $ roundtrip (Proxy :: Proxy (Solo Int)) -- no Arbitrary instance (always) + , testProperty "ByteArray" $ roundtrip (Proxy :: Proxy ByteArray) ] roundtrip :: (Eq a, Show a, Binary a) => Proxy a -> a -> Property