diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +- 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`) + - 0.1.4.0 - Add `AbsoluteTime` instance (thanks @neongreen) diff --git a/binary-orphans.cabal b/binary-orphans.cabal --- a/binary-orphans.cabal +++ b/binary-orphans.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.8.0. +-- This file has been generated from package.yaml by hpack version 0.14.0. -- -- see: https://github.com/sol/hpack name: binary-orphans -version: 0.1.4.0 +version: 0.1.5.0 synopsis: Orphan instances for binary description: `binary-orphans` defines orphan instances for types in some popular packages. category: Web @@ -30,19 +30,26 @@ src ghc-options: -Wall -fno-warn-orphans build-depends: - base >=4.6.0.1 && <4.9 - , aeson >=0.7.0.6 && <0.10.1 - , binary >=0.5.1.1 && <0.8.1 + base >=4.6.0.1 && <4.10 + , aeson >=0.7.0.6 && <0.11.3 + , binary >=0.5.1.1 && <0.8.5 + , case-insensitive >=1.2.0.4 && <1.2.1 , hashable >=1.2.3.3 && <1.3 , scientific >=0.3.3.8 && <0.4 - , semigroups >=0.16.2.2 && <0.18.1 - , tagged >=0.7.3 && <0.8.3 + , tagged >=0.7.3 && <0.8.5 , text >=1.2.0.6 && <1.3 , time >=1.4.0.1 && <1.6.1 , unordered-containers >=0.2.5.1 && <0.3 , vector >=0.10.12.3 && <0.12 , 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.2 + if !impl(ghc >= 7.10) + build-depends: + void >=0.7 && <0.8 + , nats >=1 && <1.2 exposed-modules: Data.Binary.Orphans default-language: Haskell2010 @@ -54,19 +61,26 @@ test ghc-options: -Wall -fno-warn-orphans build-depends: - base >=4.6.0.1 && <4.9 - , aeson >=0.7.0.6 && <0.10.1 - , binary >=0.5.1.1 && <0.8.1 + base >=4.6.0.1 && <4.10 + , aeson >=0.7.0.6 && <0.11.3 + , binary >=0.5.1.1 && <0.8.5 + , case-insensitive >=1.2.0.4 && <1.2.1 , hashable >=1.2.3.3 && <1.3 , scientific >=0.3.3.8 && <0.4 - , semigroups >=0.16.2.2 && <0.18.1 - , tagged >=0.7.3 && <0.8.3 + , tagged >=0.7.3 && <0.8.5 , text >=1.2.0.6 && <1.3 , time >=1.4.0.1 && <1.6.1 , unordered-containers >=0.2.5.1 && <0.3 , vector >=0.10.12.3 && <0.12 , binary-orphans - , quickcheck-instances >=0.3.11 && <0.4 + , quickcheck-instances >=0.3.11 && <0.3.13 , tasty >=0.10.1.2 && <0.12 , tasty-quickcheck >=0.8.3.2 && <0.9 + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.18.2 + if !impl(ghc >= 7.10) + build-depends: + void >=0.7 && <0.8 + , nats >=1 && <1.2 default-language: Haskell2010 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} #if MIN_VERSION_base(4,7,0) #define HAS_FIXED_CONSTRUCTOR @@ -32,19 +33,24 @@ module Data.Binary, ) where -import Control.Monad (liftM, liftM2, liftM3) +import Control.Monad (liftM, liftM2, liftM3, mzero) 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 Data.Hashable (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)) @@ -107,6 +113,10 @@ #endif #endif +------------------------------------------------------------------------------- +-- time +------------------------------------------------------------------------------- + instance Binary Time.Day where get = fmap Time.ModifiedJulianDay get put = put . Time.toModifiedJulianDay @@ -144,7 +154,12 @@ get = fmap (flip Time.addAbsoluteTime Time.taiEpoch) get put = put . flip Time.diffAbsoluteTime Time.taiEpoch + +#if !MIN_VERSION_binary(0,8,4) || !MIN_VERSION_base(4,9,0) + +------------------------------------------------------------------------------- -- Monoid +------------------------------------------------------------------------------- -- | @since 0.1.1.0 instance Binary a => Binary (Monoid.Dual a) where @@ -181,8 +196,17 @@ get = fmap Monoid.Last get put = put . Monoid.getLast --- Semigroup +#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 +------------------------------------------------------------------------------- +-- semigroups +------------------------------------------------------------------------------- + -- | /Since: binary-orphans-0.1.3.0/ instance Binary a => Binary (Semigroup.Min a) where get = fmap Semigroup.Min get @@ -212,3 +236,82 @@ 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 + +------------------------------------------------------------------------------- +-- case-insensitive +------------------------------------------------------------------------------- + +-- | /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 +------------------------------------------------------------------------------- + +#if !MIN_VERSION_binary(0,8,0) +instance Binary Void.Void where + put = Void.absurd + get = mzero +#endif + +------------------------------------------------------------------------------- +-- nats +------------------------------------------------------------------------------- + +#ifndef MIN_VERSION_nats +#define MIN_VERSION_nats(x,y,z) 0 +#endif + +#if !MIN_VERSION_binary(0,7,3) && !MIN_VERSION_nats(1,1,0) +-- Fixed-size type for a subset of Natural +type NaturalWord = Word64 + +-- | /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 + + put n = + putWord8 1 + >> put (unroll (abs n)) -- unroll the bytes + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get NaturalWord) + _ -> do bytes <- get + return $! roll bytes + + +-- +-- 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) + +roll :: (Integral a, Bits a) => [Word8] -> a +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b +#endif diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -12,7 +12,11 @@ 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 qualified Data.CaseInsensitive as CI + main :: IO () main = defaultMain tests @@ -28,8 +32,11 @@ , 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)) ] -roundtrip :: (Eq a, Show a, Arbitrary a, Binary a) => Proxy a -> a -> Property +roundtrip :: (Eq a, Show a, Binary a) => Proxy a -> a -> Property roundtrip _ x = x === decode (encode x) +instance (CI.FoldCase a, Arbitrary a) => Arbitrary (CI a) where + arbitrary = fmap CI.mk arbitrary