diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,57 @@ +## 1 + +- **Breaking change** rename this package to `binary-instances`. +It was previously known as `binary-orphans`, which is now only a subset. + +- Depend on [`time-compat`](http://hackage.haskell.org/package/time-compat) + to provide `Binary` instances for `time` types. + +## 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.x + +## 0.1.5.1 + +- Fix issue with binary-0.8.4.x and GHC-7.x + +## 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`) + +## 0.1.2.0 + +- Support `scientific >= 0.3.4` + +## 0.1.1.0 + +- Add `Dual`, `All`, `Any`, `Sum`, `Product`, `First` and `Last` instances diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, 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 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. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/binary-instances.cabal b/binary-instances.cabal new file mode 100644 --- /dev/null +++ b/binary-instances.cabal @@ -0,0 +1,81 @@ +name: binary-instances +version: 1 +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 +build-type: Simple +cabal-version: >=1.10 +tested-with: + GHC ==8.8.1 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 + +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/phadej/binary-orphans + +library + hs-source-dirs: src + build-depends: + aeson >=0.7.0.6 && <1.5 + , base >=4.6.0.1 && <4.13 + , binary >=0.5.1.1 && <0.8.7 + , binary-orphans >=1.0.1 && <1.1 + , case-insensitive >=1.2.0.4 && <1.2.2 + , hashable >=1.2.3.3 && <1.4 + , scientific >=0.3.3.8 && <0.4 + , tagged >=0.7.3 && <0.8.7 + , text >=1.2.0.6 && <1.3 + , text-binary >=0.2.1.1 && <0.3 + , time-compat >=1.9.2.2 && <1.10 + , unordered-containers >=0.2.5.1 && <0.3 + , vector >=0.10.12.3 && <0.13 + , vector-binary-instances >=0.2.1.0 && <0.3 + + exposed-modules: + Data.Binary.Instances + Data.Binary.Instances.Aeson + Data.Binary.Instances.CaseInsensitive + Data.Binary.Instances.Scientific + Data.Binary.Instances.Text + Data.Binary.Instances.Time + Data.Binary.Instances.Tagged + Data.Binary.Instances.Hashable + Data.Binary.Instances.UnorderedContainers + Data.Binary.Instances.Vector + + default-language: Haskell2010 + +test-suite binary-instances-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + ghc-options: -Wall -fno-warn-orphans + build-depends: + aeson + , base + , binary + , binary-instances + , case-insensitive + , hashable + , QuickCheck >=2.13.1 && <2.14 + , quickcheck-instances >=0.3.21 && <0.4 + , scientific + , tagged + , tasty >=0.10.1.2 && <1.3 + , tasty-quickcheck >=0.8.3.2 && <0.11 + , text + , time-compat + , unordered-containers + , vector + diff --git a/src/Data/Binary/Instances.hs b/src/Data/Binary/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Orphans +-- Copyright : (C) 2015-2019 Oleg Grenrus +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- Provides orphan 'Binary' instances for types in various packages: +-- +-- * aeson +-- * case-insensitive +-- * hashable +-- * scientific (prior to scientific-0.3.4.0) +-- * tagged +-- * text (through text-binary, or text >= 1.2.1) +-- * time +-- * unordered-containers +-- * vector (through vector-binary-instances) +-- +module Data.Binary.Instances () where + +import Data.Binary.Orphans () + +import Data.Binary.Instances.Aeson () +import Data.Binary.Instances.CaseInsensitive () +import Data.Binary.Instances.Hashable () +import Data.Binary.Instances.Scientific () +import Data.Binary.Instances.Tagged () +import Data.Binary.Instances.Text () +import Data.Binary.Instances.Time () +import Data.Binary.Instances.UnorderedContainers () +import Data.Binary.Instances.Vector () diff --git a/src/Data/Binary/Instances/Aeson.hs b/src/Data/Binary/Instances/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Aeson.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Aeson where + +import Data.Binary (Binary, Get, get, put) +import Data.Binary.Orphans () + +import Data.Binary.Instances.Scientific () +import Data.Binary.Instances.Text () +import Data.Binary.Instances.UnorderedContainers () +import Data.Binary.Instances.Vector () + +import qualified Data.Aeson as A + +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) diff --git a/src/Data/Binary/Instances/CaseInsensitive.hs b/src/Data/Binary/Instances/CaseInsensitive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/CaseInsensitive.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.CaseInsensitive where + +import Data.Binary (Binary, get, put) +import Data.Binary.Orphans () + +import qualified Data.CaseInsensitive as CI + +instance (CI.FoldCase a, Binary a) => Binary (CI.CI a) where + get = fmap CI.mk get + put = put . CI.foldedCase diff --git a/src/Data/Binary/Instances/Hashable.hs b/src/Data/Binary/Instances/Hashable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Hashable.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Hashable where + +import Data.Binary.Orphans () + +#if MIN_VERSION_hashable(1,2,5) +import Data.Binary (Binary, get, put) +import qualified Data.Hashable as Hashable + +instance (Hashable.Hashable a, Binary a) => Binary (Hashable.Hashed a) where + get = fmap Hashable.hashed get + put = put . Hashable.unhashed +#endif diff --git a/src/Data/Binary/Instances/Scientific.hs b/src/Data/Binary/Instances/Scientific.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Scientific.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Scientific where + +import Data.Binary.Orphans () + +#if !(MIN_VERSION_scientific(0,3,4)) +import Control.Monad (liftM2) +import Data.Binary (Binary, Get, Put, get, put) + +import qualified Data.Scientific as S + +instance Binary S.Scientific where + get = liftM2 S.scientific get get + put s = put (S.coefficient s) >> put (S.base10Exponent s) +#endif diff --git a/src/Data/Binary/Instances/Tagged.hs b/src/Data/Binary/Instances/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Tagged.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +module Data.Binary.Instances.Tagged where + +import Data.Binary (Binary, get, put) +import Data.Binary.Orphans () + +import qualified Data.Tagged as Tagged + +instance Binary b => Binary (Tagged.Tagged s b) where + put = put . Tagged.unTagged + get = fmap Tagged.Tagged get diff --git a/src/Data/Binary/Instances/Text.hs b/src/Data/Binary/Instances/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Text.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Text where + +import Data.Binary.Orphans () + +#if !(MIN_VERSION_text(1,2,1)) +import Data.Text.Binary () +#endif diff --git a/src/Data/Binary/Instances/Time.hs b/src/Data/Binary/Instances/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Time.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Time where + +import Control.Monad (liftM2, liftM3) +import Data.Binary (Binary, Get, Put, get, put) +import Data.Binary.Orphans () +import Data.Word (Word8) + +import qualified Data.Fixed as Fixed +import qualified Data.Time.Calendar.Compat as Time +import qualified Data.Time.Clock.Compat as Time +import qualified Data.Time.Clock.System.Compat as Time +import qualified Data.Time.Clock.TAI.Compat as Time +import qualified Data.Time.LocalTime.Compat as 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 + +instance Binary Time.ZonedTime where + get = liftM2 Time.ZonedTime get get + put (Time.ZonedTime t z) = put t >> put z + +instance Binary Time.AbsoluteTime where + get = fmap (flip Time.addAbsoluteTime Time.taiEpoch) get + put = put . flip Time.diffAbsoluteTime Time.taiEpoch + +instance Binary Time.SystemTime where + get = liftM2 Time.MkSystemTime get get + put (Time.MkSystemTime s ns) = put s >> put ns + +instance Binary Time.CalendarDiffDays where + get = liftM2 Time.CalendarDiffDays get get + put (Time.CalendarDiffDays m d) = put m >> put d + +instance Binary Time.CalendarDiffTime where + get = liftM2 Time.CalendarDiffTime get get + put (Time.CalendarDiffTime m nt) = put m >> put nt + +instance Binary Time.DayOfWeek where + put Time.Sunday = put (0 :: Word8) + put Time.Monday = put (1 :: Word8) + put Time.Tuesday = put (2 :: Word8) + put Time.Wednesday = put (3 :: Word8) + put Time.Thursday = put (4 :: Word8) + put Time.Friday = put (5 :: Word8) + put Time.Saturday = put (6 :: Word8) + + get = do + i <- get + return $ case mod (i :: Word8) 7 of + 0 -> Time.Sunday + 1 -> Time.Monday + 2 -> Time.Tuesday + 3 -> Time.Wednesday + 4 -> Time.Thursday + 5 -> Time.Friday + 6 -> Time.Saturday + _ -> error "panic: get @DayOfWeek" diff --git a/src/Data/Binary/Instances/UnorderedContainers.hs b/src/Data/Binary/Instances/UnorderedContainers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/UnorderedContainers.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.UnorderedContainers where + +import Data.Binary (Binary, get, put) +import Data.Binary.Orphans () + +import qualified Data.Hashable as Hashable +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS + +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 diff --git a/src/Data/Binary/Instances/Vector.hs b/src/Data/Binary/Instances/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Instances/Vector.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Binary.Instances.Vector where + +import Data.Binary.Orphans () +import Data.Vector.Binary () diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Data.Binary.Instances () +import Test.QuickCheck.Instances () + +import Data.Binary (Binary, decode, encode) +import Data.Typeable (Typeable, typeOf) +import Test.QuickCheck (Arbitrary, Property, (===)) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Data.CaseInsensitive (CI) +import Data.HashMap.Lazy (HashMap) +import Data.HashSet (HashSet) +import Data.Monoid (Sum) +import Data.Scientific (Scientific) +import Data.Tagged (Tagged) +import Data.Text (Text) +import Data.Vector (Vector) + +import qualified Data.Vector.Unboxed as VU + +import qualified Data.Time.Calendar.Compat as Time +import qualified Data.Time.Clock.Compat as Time +import qualified Data.Time.Clock.System.Compat as Time +import qualified Data.Time.Clock.TAI.Compat as Time +import qualified Data.Time.LocalTime.Compat as Time + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Roundtrip" + -- unordered containers + [ roundtripProperty (undefined :: (HashMap Int String)) + , roundtripProperty (undefined :: (HashSet Int)) + -- time + , roundtripProperty (undefined :: Time.AbsoluteTime) + , roundtripProperty (undefined :: Time.CalendarDiffDays) + , roundtripProperty (undefined :: Time.CalendarDiffTime) + , roundtripProperty (undefined :: Time.Day) + , roundtripProperty (undefined :: Time.DayOfWeek) + , roundtripProperty (undefined :: Time.DiffTime) + , roundtripProperty (undefined :: Time.LocalTime) + , roundtripProperty (undefined :: Time.NominalDiffTime) + , roundtripProperty (undefined :: Time.SystemTime) + , roundtripProperty (undefined :: Time.TimeOfDay) + , roundtripProperty (undefined :: Time.TimeZone) + , roundtripProperty (undefined :: Time.UTCTime) + -- case-insensitive & text + , roundtripProperty (undefined :: (CI Text)) + -- semigroups / monoids + , roundtripProperty (undefined :: (Sum Int)) + -- tagged + , roundtripProperty (undefined :: Tagged Int Char) + -- scientific + , roundtripProperty (undefined :: Scientific) + -- vector + , roundtripProperty (undefined :: Vector Char) + , roundtripProperty (undefined :: VU.Vector Char) + ] + +roundtrip :: (Eq a, Show a, Binary a) => a -> a -> Property +roundtrip _ x = x === decode (encode x) + +roundtripProperty + :: forall a. (Eq a, Show a, Binary a, Arbitrary a, Typeable a) + => a -> TestTree +roundtripProperty x = testProperty (show (typeOf x)) $ roundtrip x