{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}
module Data.Binary.Orphans () where
import Data.Binary
import Data.Binary.Put
import Control.Applicative (Alternative (..))
import Control.Monad
(MonadPlus (..), liftM, liftM2, replicateM)
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_base(4,16,0)
import Data.Tuple (Solo (..))
#else
import Data.Tuple.Solo (Solo (..))
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Array.Byte (ByteArray (..), MutableByteArray (..))
import GHC.Exts
(Int (..), indexWord8Array#, newByteArray#, sizeofByteArray#,
unsafeFreezeByteArray#, writeWord8Array#)
import GHC.ST (ST (..), runST)
import GHC.Word (Word8 (..))
#endif
#if !(MIN_VERSION_binary(0,7,1))
#endif
#if !(MIN_VERSION_binary(0,7,3) )
#ifndef MIN_VERSION_nats
#define MIN_VERSION_nats(x,y,z) 0
#endif
#if !(MIN_VERSION_nats(1,1,0))
type NaturalWord = Word64
instance Binary Natural where
{-# INLINE put #-}
put n | n <= hi =
putWord8 0
>> put (fromIntegral n :: NaturalWord)
where
hi = fromIntegral (maxBound :: NaturalWord) :: Natural
put n =
putWord8 1
>> put (unroll (abs n))
{-# INLINE get #-}
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
#endif
#if !MIN_VERSION_binary(0,7,6)
instance Binary Fingerprint where
put (Fingerprint x1 x2) = put x1 <> put x2
get = do
x1 <- get
x2 <- get
return $! Fingerprint x1 x2
#endif
#if !(MIN_VERSION_binary(0,8,0))
instance Binary Version where
put (Version br tags) = put br <> put tags
get = liftM2 Version get get
instance Binary Void where
put = absurd
get = fail "get @Void"
#if MIN_VERSION_base(4,7,0)
instance Binary (Fixed.Fixed a) where
put (Fixed.MkFixed a) = put a
get = Fixed.MkFixed `fmap` 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))) `fmap` get
#endif
#endif
#if !(MIN_VERSION_binary(0,8,2)) || !(MIN_VERSION_base(4,9,0))
instance Fail.MonadFail Get where
fail = Prelude.fail
#endif
#if !(MIN_VERSION_binary(0,8,3)) || !(MIN_VERSION_base(4,9,0))
instance Semigroup.Semigroup Put where
(<>) = (>>)
#endif
#if !(MIN_VERSION_binary(0,8,3))
instance Monoid.Monoid Put where
mempty = return ()
mappend = (<>)
#endif
#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
#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 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
instance Binary a => Binary (NE.NonEmpty a) where
get = do
x <- get
case x of
[] -> fail "empty NonEmpty"
(x:xs) -> return (x NE.:| xs)
put = put . NE.toList
#endif
#if !(MIN_VERSION_binary(8,6,0))
#endif
#if !(MIN_VERSION_binary(8,6,0))
#if !MIN_VERSION_base(4,8,0)
instance Binary a => Binary (Identity a) where
put (Identity x) = put x
get = fmap Identity get
#endif
#endif
instance Binary a => Binary (Solo a) where
put :: Solo a -> Put
put (Solo a
x) = forall t. Binary t => t -> Put
put a
x
get :: Get (Solo a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Solo a
Solo forall t. Binary t => Get t
get
#if MIN_VERSION_base(4,9,0)
instance Binary ByteArray where
put :: ByteArray -> Put
put ByteArray
ba = forall t. Binary t => t -> Put
put Int
maxI forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
go Int
0
where
maxI :: Int
maxI :: Int
maxI = ByteArray -> Int
sizeofByteArray ByteArray
ba
go :: Int -> Put
go :: Int -> Put
go Int
i | Int
i forall a. Ord a => a -> a -> Bool
< Int
maxI = forall t. Binary t => t -> Put
put (ByteArray -> Int -> Word8
indexByteArray ByteArray
ba Int
i) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
get :: Get ByteArray
get = do
Int
len <- forall t. Binary t => Get t
get
[Word8]
xs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len forall t. Binary t => Get t
get
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Word8] -> ByteArray
byteArrayFromListN Int
len [Word8]
xs)
{-# INLINE sizeofByteArray #-}
sizeofByteArray :: ByteArray -> Int
sizeofByteArray :: ByteArray -> Int
sizeofByteArray (ByteArray ByteArray#
ba) = Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
ba)
{-# INLINE indexByteArray #-}
indexByteArray :: ByteArray -> Int -> Word8
indexByteArray :: ByteArray -> Int -> Word8
indexByteArray (ByteArray ByteArray#
ba) (I# Int#
i) = Word8# -> Word8
W8# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba Int#
i)
{-# INLINE byteArrayFromListN #-}
byteArrayFromListN :: Int -> [Word8] -> ByteArray
byteArrayFromListN :: Int -> [Word8] -> ByteArray
byteArrayFromListN Int
len [Word8]
xs = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MutableByteArray s
mba <- forall s. Int -> ST s (MutableByteArray s)
newByteArray Int
len
forall s. MutableByteArray s -> Int -> [Word8] -> ST s ()
go MutableByteArray s
mba Int
0 [Word8]
xs
forall s. MutableByteArray s -> ST s ByteArray
unsafeFreezeByteArray MutableByteArray s
mba
where
go :: MutableByteArray s -> Int -> [Word8] -> ST s ()
go :: forall s. MutableByteArray s -> Int -> [Word8] -> ST s ()
go MutableByteArray s
mba Int
i [Word8]
ys
| Int
i forall a. Ord a => a -> a -> Bool
< Int
len = case [Word8]
ys of
[] -> forall s. MutableByteArray s -> Int -> Word8 -> ST s ()
writeWord8Array MutableByteArray s
mba Int
i Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. MutableByteArray s -> Int -> [Word8] -> ST s ()
go MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
1) [Word8]
ys
Word8
z:[Word8]
zs -> forall s. MutableByteArray s -> Int -> Word8 -> ST s ()
writeWord8Array MutableByteArray s
mba Int
i Word8
z forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. MutableByteArray s -> Int -> [Word8] -> ST s ()
go MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
1) [Word8]
zs
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE newByteArray #-}
newByteArray :: Int -> ST s (MutableByteArray s)
newByteArray :: forall s. Int -> ST s (MutableByteArray s)
newByteArray (I# Int#
len) = forall s a. STRep s a -> ST s a
ST forall a b. (a -> b) -> a -> b
$ \State# s
s -> case forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
len State# s
s of
(# State# s
s', MutableByteArray# s
mba #) -> (# State# s
s', forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# s
mba #)
{-# INLINE unsafeFreezeByteArray #-}
unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray
unsafeFreezeByteArray :: forall s. MutableByteArray s -> ST s ByteArray
unsafeFreezeByteArray (MutableByteArray MutableByteArray# s
mba) = forall s a. STRep s a -> ST s a
ST forall a b. (a -> b) -> a -> b
$ \State# s
s -> case forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# s
mba State# s
s of
(# State# s
s', ByteArray#
ba #) -> (# State# s
s', ByteArray# -> ByteArray
ByteArray ByteArray#
ba #)
{-# INLINE writeWord8Array #-}
writeWord8Array :: MutableByteArray s -> Int -> Word8 -> ST s ()
writeWord8Array :: forall s. MutableByteArray s -> Int -> Word8 -> ST s ()
writeWord8Array (MutableByteArray MutableByteArray# s
mba) (I# Int#
i) (W8# Word8#
w) = forall s a. STRep s a -> ST s a
ST forall a b. (a -> b) -> a -> b
$ \State# s
s -> case forall d.
MutableByteArray# d -> Int# -> Word8# -> State# d -> State# d
writeWord8Array# MutableByteArray# s
mba Int#
i Word8#
w State# s
s of
State# s
s' -> (# State# s
s', () #)
#endif