{-# 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

-------------------------------------------------------------------------------
-- 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

-------------------------------------------------------------------------------
-- 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

#if !(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


--
-- 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

#endif

-------------------------------------------------------------------------------
-- binary-0.7.6.0
-------------------------------------------------------------------------------

#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 `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))) `fmap` get
#endif

#endif

-------------------------------------------------------------------------------
-- Added semigroup instance for Data.Binary.Builder from GHC 8.0.

-- in semigroups

-------------------------------------------------------------------------------
-- binary-0.8.2.0
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
-- When using GHC >= 8, Data.Binary.Get.Get implements MonadFail and delegates its fail to MonadFail.fail.

#if !(MIN_VERSION_binary(0,8,2)) || !(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

-------------------------------------------------------------------------------
-- binary-0.8.3
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- Add Monoid and Semigroup instance for Put.

#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

-------------------------------------------------------------------------------
-- 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

-------------------------------------------------------------------------------
-- binary-0.8.4
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- 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

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

------------------------------------------------------------------------
-- Data.Semigroup datatypes

#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

-------------------------------------------------------------------------------
-- binary-0.8.5.0
-------------------------------------------------------------------------------

#if !(MIN_VERSION_binary(8,6,0))

-------------------------------------------------------------------------------
-- Typeable TypeReps
-- Add Binary instances for Typeable TypeReps
-- https://github.com/kolmodin/binary/pull/131

-- TODO

#endif

-------------------------------------------------------------------------------
-- binary-0.8.6.0
-------------------------------------------------------------------------------

#if !(MIN_VERSION_binary(8,6,0))

-------------------------------------------------------------------------------
-- Add binary instance for Data.Functor.Identity from base,
-- https://github.com/kolmodin/binary/pull/146

#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

-------------------------------------------------------------------------------
-- future-binary
-------------------------------------------------------------------------------

-- | @since 1.0.2
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)
-- | @since 1.0.3
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