{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif
#ifndef HAS_FIXED_CONSTRUCTOR
{-# LANGUAGE ScopedTypeVariables #-}
#endif
module Data.Binary.Orphans (
Binary(..),
module Data.Binary,
) where
import Control.Monad (liftM, liftM2, liftM3)
import qualified Data.Aeson as A
import Data.Binary
import qualified Data.Fixed as Fixed
import qualified Data.HashMap.Lazy as HM
import qualified Data.HashSet as HS
import Data.Hashable (Hashable)
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
#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
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 k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where
get = fmap HM.fromList get
put = put . HM.toList
instance (Hashable v, Eq v, Binary v) => Binary (HS.HashSet v) where
get = fmap HS.fromList get
put = put . HS.toList
#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.AbsoluteTime where
get = fmap (flip Time.addAbsoluteTime Time.taiEpoch) get
put = put . flip Time.diffAbsoluteTime Time.taiEpoch
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
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