diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,38 +1,5 @@ -- 0.1.8.0 - - `ZonedTime` instance (by @mstksg) - -- 0.1.7.0 - - GHC-8.2 support - - `SystemTime` instance (`time-1.8`) - -- 0.1.6.0 - - Add instance for `hashed` in `hashable >=1.2.5.0` - -- 0.1.5.2 - - Fix issue with binary-0.5.* - -- 0.1.5.1 - - Fix issue with binary-0.8.4.* and GHC-7.* - -- 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) - -- 0.1.3.1 - - Support GHC 7.6 - -- 0.1.3.0 - - Add `Min`, `Max`, `First`, `Last`, `Option`, and `NonEmpty` instances (from `semigroups`) +# 1 -- 0.1.2.0 - - Support `scientific >= 0.3.4` +Stripped down the package to only shim `binary` orphans. -- 0.1.1.0 - - Add `Dual`, `All`, `Any`, `Sum`, `Product`, `First` and `Last` instances +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,66 @@ -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 +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 ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 +extra-source-files: CHANGELOG.md + source-repository head - type: git - location: https://github.com/phadej/binary-orphans + type: git + location: git://github.com/phadej/binary-orphans.git 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 + exposed-modules: Data.Binary.Orphans + other-extensions: CPP + build-depends: + base >=4.5 && <4.14 + , binary >=0.5.1.0 && <0.6 || >=0.7.1.0 && <0.8 || >=0.8.3.0 && <0.8.7 + , transformers >=0.3.0.0 && <0.7 + if !impl(ghc >=7.10) + build-depends: nats >=1.1.2 && <1.2 + build-depends: void >=0.7.3 && <0.8 + + if !impl(ghc >=8.0) + build-depends: fail ==4.9.* + build-depends: semigroups >=0.18.5 && <0.19.1 + 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) + , QuickCheck >=2.13.1 && <2.14 + , quickcheck-instances >=0.3.21 && <0.4 + , tasty >=0.10.1.2 && <1.3 + , tasty-quickcheck >=0.8.3.2 && <0.11 + , tagged >=0.8.6 && <0.8.7 + + if !impl(ghc >=8.0) + build-depends: semigroups + + if !impl(ghc >=7.10) build-depends: - void >=0.7 && <0.8 - , nats >=1 && <1.2 - default-language: Haskell2010 + nats + , void 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,324 @@ -{-# 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 ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} #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 +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} +module Data.Binary.Orphans () 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 +import Data.Binary +import Data.Binary.Put --- From other packages -#if !(MIN_VERSION_text(1,2,1)) -import Data.Text.Binary () -#endif -import Data.Vector.Binary () +import Control.Applicative (Alternative (..)) +import Control.Monad (MonadPlus (..), liftM, liftM2) +import qualified Control.Monad.Fail as Fail +import Data.Bits (Bits, shiftL, shiftR, (.|.)) +import Data.Complex (Complex (..)) +import qualified Data.Fixed as Fixed +import Data.Functor.Identity (Identity (..)) +import Data.List (foldl', unfoldr) +import qualified Data.List.NonEmpty as NE +import qualified Data.Monoid as Monoid +import Data.Semigroup ((<>)) +import qualified Data.Semigroup as Semigroup +import Data.Version (Version (..)) +import Data.Void (Void, absurd) +import GHC.Fingerprint (Fingerprint (..)) +import Numeric.Natural (Natural) -#if !(MIN_VERSION_scientific(0,3,4)) -import qualified Data.Scientific as S +------------------------------------------------------------------------------- +-- binary-0.7.1.0 +------------------------------------------------------------------------------- + +#if !(MIN_VERSION_binary(0,7,1)) + +------------------------------------------------------------------------------- +-- Add MonadPlus instance for Get. + +-- Not implementable, as far as I can see + #endif -#if MIN_VERSION_time(1,8,0) -import qualified Data.Time.Clock.System as Time +------------------------------------------------------------------------------- +-- binary-0.7.3.0 +------------------------------------------------------------------------------- + +#if !(MIN_VERSION_binary(0,7,3) ) + +------------------------------------------------------------------------------- +-- Add Binary instance for Natural (only with base > 4.8). + +#ifndef MIN_VERSION_nats +#define MIN_VERSION_nats(x,y,z) 0 #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 +#if !(MIN_VERSION_nats(1,1,0)) +-- Fixed-size type for a subset of Natural +type NaturalWord = Word64 - 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) +-- | /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 -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 + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get NaturalWord) + _ -> do bytes <- get + return $! roll bytes -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 +-- +-- 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 -#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 -instance Binary b => Binary (Tagged.Tagged s b) where - put = put . Tagged.unTagged - get = fmap Tagged.Tagged get +------------------------------------------------------------------------------- +-- binary-0.7.6.0 +------------------------------------------------------------------------------- -#if !MIN_VERSION_binary(0,8,0) -#ifdef HAS_FIXED_CONSTRUCTOR +#if !MIN_VERSION_binary(0,7,6) + +------------------------------------------------------------------------------- +-- Added binary instance for GHC.Fingerprint (from GHC >= 7.4). + +instance Binary Fingerprint where + put (Fingerprint x1 x2) = put x1 <> put x2 + get = do + x1 <- get + x2 <- get + return $! Fingerprint x1 x2 + +#endif + +------------------------------------------------------------------------------- +-- binary-0.8.0.0 +------------------------------------------------------------------------------- + +#if !(MIN_VERSION_binary(0,8,0)) + +------------------------------------------------------------------------------- +-- Added binary instance for Version from Data.Version. + +instance Binary Version where + put (Version br tags) = put br <> put tags + get = liftM2 Version get get + +------------------------------------------------------------------------------- +-- Added binary instance for Void from GHC 7.10.1. + +instance Binary Void where + put = absurd + get = fail "get @Void" + +------------------------------------------------------------------------------- +-- Added binary instance for (Data.Fixed a) from GHC 7.8.1. + +#if MIN_VERSION_base(4,7,0) instance Binary (Fixed.Fixed a) where put (Fixed.MkFixed a) = put a - get = Fixed.MkFixed `liftM` get + get = Fixed.MkFixed `fmap` get #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 + get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `fmap` get #endif + #endif ------------------------------------------------------------------------------- --- time -------------------------------------------------------------------------------- +-- Added semigroup instance for Data.Binary.Builder from GHC 8.0. -instance Binary Time.Day where - get = fmap Time.ModifiedJulianDay get - put = put . Time.toModifiedJulianDay +-- in semigroups -instance Binary Time.UniversalTime where - get = fmap Time.ModJulianDate get - put = put . Time.getModJulianDate +------------------------------------------------------------------------------- +-- binary-0.8.2.0 +------------------------------------------------------------------------------- -instance Binary Time.DiffTime where - get = fmap Time.picosecondsToDiffTime get - put = (put :: Fixed.Pico -> Put) . realToFrac +#if !(MIN_VERSION_binary(0,8,2)) -instance Binary Time.UTCTime where - get = liftM2 Time.UTCTime get get - put (Time.UTCTime d dt) = put d >> put dt +------------------------------------------------------------------------------- +-- When using GHC >= 8, Data.Binary.Get.Get implements MonadFail and delegates its fail to MonadFail.fail. -instance Binary Time.NominalDiffTime where - get = fmap realToFrac (get :: Get Fixed.Pico) - put = (put :: Fixed.Pico -> Put) . realToFrac +#if !(MIN_VERSION_base(4,9,0)) +instance Fail.MonadFail Get where + -- this is ok, as if old base: Prelude.fail is Monad's fail + fail = Prelude.fail +#endif -instance Binary Time.TimeZone where - get = liftM3 Time.TimeZone get get get - put (Time.TimeZone m s n) = put m >> put s >> put n +#endif -instance Binary Time.TimeOfDay where - get = liftM3 Time.TimeOfDay get get get - put (Time.TimeOfDay h m s) = put h >> put m >> put s +------------------------------------------------------------------------------- +-- binary-0.8.3 +------------------------------------------------------------------------------- -instance Binary Time.LocalTime where - get = liftM2 Time.LocalTime get get - put (Time.LocalTime d tod) = put d >> put tod +------------------------------------------------------------------------------- +-- Add Monoid and Semigroup instance for Put. --- | /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 +#if !(MIN_VERSION_binary(0,8,3)) || !(MIN_VERSION_base(4,9,0)) +instance Semigroup.Semigroup Put where + (<>) = (>>) +#endif --- | /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_binary(0,8,3)) +instance Monoid.Monoid Put where + mempty = return () + mappend = (<>) -#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) +------------------------------------------------------------------------------- +-- Add Binary instance for Complex a. +#if !(MIN_VERSION_binary(0,8,3)) + +instance Binary a => Binary (Complex a) where + {-# INLINE put #-} + put (r :+ i) = put (r, i) + {-# INLINE get #-} + get = fmap (\(r,i) -> r :+ i) get + +#endif + ------------------------------------------------------------------------------- --- Monoid +-- binary-0.8.4 ------------------------------------------------------------------------------- --- | @since 0.1.1.0 +------------------------------------------------------------------------------- +-- Add Binary instances for datatypes in Data.Monoid/Data.Semigroup +-- https://github.com/kolmodin/binary/pull/114 + +#if !MIN_VERSION_binary(0,8,4) + 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 + #endif -------------------------------------------------------------------------------- --- semigroups -------------------------------------------------------------------------------- +------------------------------------------------------------------------ +-- Data.Semigroup datatypes #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 + put (Semigroup.Arg a b) = put a <> put b + +instance Binary a => Binary (NE.NonEmpty a) where + get = fmap NE.fromList get + put = put . NE.toList + #endif ------------------------------------------------------------------------------- --- case-insensitive +-- binary-0.8.5.0 ------------------------------------------------------------------------------- --- | /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 +#if !(MIN_VERSION_binary(8,6,0)) ------------------------------------------------------------------------------- --- void -------------------------------------------------------------------------------- +-- Typeable TypeReps +-- Add Binary instances for Typeable TypeReps +-- https://github.com/kolmodin/binary/pull/131 -#if !MIN_VERSION_binary(0,8,0) -instance Binary Void.Void where - put = Void.absurd - get = fail "Binary.get @Void" +-- TODO + #endif ------------------------------------------------------------------------------- --- nats +-- binary-0.8.6.0 ------------------------------------------------------------------------------- -#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 +#if !(MIN_VERSION_binary(8,6,0)) +------------------------------------------------------------------------------- +-- Add binary instance for Data.Functor.Identity from base, +-- https://github.com/kolmodin/binary/pull/146 --- --- 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) +#if !MIN_VERSION_base(4,8,0) +instance Binary a => Binary (Identity a) where + put (Identity x) = put x + get = fmap Identity get +#endif -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 @@ -1,43 +1,25 @@ {-# LANGUAGE CPP #-} module Main (main) where -import Data.Binary +import Data.Binary (Binary, decode, encode) import Data.Binary.Orphans () +import Data.Monoid (Sum) import Data.Proxy +import Data.Semigroup (Min (..)) +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)) ] roundtrip :: (Eq a, Show a, Binary a) => Proxy a -> a -> Property