#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif
#ifndef HAS_FIXED_CONSTRUCTOR
#endif
module Data.Binary.Orphans (
Binary(..),
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
#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
#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
#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
#else
instance Fixed.HasResolution a => Binary (Fixed.Fixed a) where
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
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
#if MIN_VERSION_time(1,8,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)
instance Binary a => Binary (Monoid.Dual a) where
get = fmap Monoid.Dual get
put = put . Monoid.getDual
instance Binary Monoid.All where
get = fmap Monoid.All get
put = put . Monoid.getAll
instance Binary Monoid.Any where
get = fmap Monoid.Any get
put = put . Monoid.getAny
instance Binary a => Binary (Monoid.Sum a) where
get = fmap Monoid.Sum get
put = put . Monoid.getSum
instance Binary a => Binary (Monoid.Product a) where
get = fmap Monoid.Product get
put = put . Monoid.getProduct
instance Binary a => Binary (Monoid.First a) where
get = fmap Monoid.First get
put = put . Monoid.getFirst
instance Binary a => Binary (Monoid.Last a) where
get = fmap Monoid.Last get
put = put . Monoid.getLast
#if MIN_VERSION_base(4,8,0)
instance Binary (f a) => Binary (Monoid.Alt f a) where
get = fmap Monoid.Alt get
put = put . Monoid.getAlt
#endif
#endif
#if !MIN_VERSION_binary(0,8,4) || !MIN_VERSION_base(4,9,0)
instance Binary a => Binary (Semigroup.Min a) where
get = fmap Semigroup.Min get
put = put . Semigroup.getMin
instance Binary a => Binary (Semigroup.Max a) where
get = fmap Semigroup.Max get
put = put . Semigroup.getMax
instance Binary a => Binary (Semigroup.First a) where
get = fmap Semigroup.First get
put = put . Semigroup.getFirst
instance Binary a => Binary (Semigroup.Last a) where
get = fmap Semigroup.Last get
put = put . Semigroup.getLast
instance Binary a => Binary (Semigroup.Option a) where
get = fmap Semigroup.Option get
put = put . Semigroup.getOption
instance Binary a => Binary (NE.NonEmpty a) where
get = fmap NE.fromList get
put = put . NE.toList
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
get = fmap Semigroup.WrapMonoid get
put = put . Semigroup.unwrapMonoid
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
instance (CI.FoldCase a, Binary a) => Binary (CI.CI a) where
get = fmap CI.mk get
put = put . CI.foldedCase
#if !MIN_VERSION_binary(0,8,0)
instance Binary Void.Void where
put = Void.absurd
get = fail "Binary.get @Void"
#endif
#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)
type NaturalWord = Word64
instance Binary Natural where
put n | n <= hi =
putWord8 0
>> put (fromIntegral n :: NaturalWord)
where
hi = fromIntegral (maxBound :: NaturalWord) :: Natural
put n =
putWord8 1
>> put (unroll (abs n))
get = do
tag <- get :: Get Word8
case tag of
0 -> liftM fromIntegral (get :: Get NaturalWord)
_ -> do bytes <- get
return $! roll 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