{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- |
-- Module      : Codec.Serialise.Class
-- Copyright   : (c) Duncan Coutts 2015-2017
-- License     : BSD3-style (see LICENSE.txt)
--
-- Maintainer  : duncan@community.haskell.org
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- The @'Serialise'@ class allows you to encode a given type into a
-- CBOR object, or decode a CBOR object into the user-specified type.
--
module Codec.Serialise.Class
 ( -- * The Serialise class
   Serialise(..)
 , GSerialiseEncode(..)
 , GSerialiseDecode(..)
 , encodeVector
 , decodeVector
 ) where

import           Control.Applicative

import           Control.Monad
import           Data.Hashable
import           Data.Int
import           Data.Monoid
import           Data.Proxy
import           Data.Version
import           Data.Word
import           Data.Complex
import           Data.Fixed
import           Data.Ratio
import           Data.Ord

#if MIN_VERSION_base(4,8,0)
import           Numeric.Natural
import           Data.Functor.Identity
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup                      as Semigroup
import qualified Data.List.NonEmpty                  as NonEmpty
#endif

import qualified Data.Foldable                       as Foldable
import qualified Data.ByteString                     as BS
import qualified Data.Text                           as Text

-- TODO FIXME: more instances
--import qualified Data.Array                          as Array
--import qualified Data.Array.Unboxed                  as UArray
import qualified Data.ByteString.Lazy                as BS.Lazy
import qualified Data.Map                            as Map
import qualified Data.Sequence                       as Sequence
import qualified Data.Set                            as Set
import qualified Data.IntSet                         as IntSet
import qualified Data.IntMap                         as IntMap
import qualified Data.HashSet                        as HashSet
import qualified Data.HashMap.Strict                 as HashMap
import qualified Data.Tree                           as Tree
import qualified Data.Vector                         as Vector
import qualified Data.Vector.Unboxed                 as Vector.Unboxed
import qualified Data.Vector.Storable                as Vector.Storable
import qualified Data.Vector.Primitive               as Vector.Primitive
import qualified Data.Vector.Generic                 as Vector.Generic
import qualified Data.Text.Lazy                      as Text.Lazy
import           Foreign.C.Types
import qualified Numeric.Half                        as Half

import           Data.Time                           (UTCTime (..), addUTCTime)
import           Data.Time.Calendar                  (fromGregorian)
import           Data.Time.Clock.POSIX               (POSIXTime, utcTimeToPOSIXSeconds,
                                                      posixSecondsToUTCTime)
#if MIN_VERSION_time(1,5,0)
import           Data.Time.Format                    (defaultTimeLocale, parseTimeM)
#else
import           Data.Time.Format                    (parseTime)
import           System.Locale                       (defaultTimeLocale)
#endif
import           System.Exit                         (ExitCode(..))

import           Prelude hiding (decodeFloat, encodeFloat, foldr)
import qualified Prelude
#if MIN_VERSION_base(4,10,0)
import           Type.Reflection
import           Type.Reflection.Unsafe
import           GHC.Fingerprint
import           GHC.Exts (VecCount(..), VecElem(..), RuntimeRep(..))
import           Data.Kind (Type)
#else
import           Data.Typeable.Internal
#endif
import           GHC.Generics

import           Codec.CBOR.Decoding
import           Codec.CBOR.Encoding
import           Codec.CBOR.Term


--------------------------------------------------------------------------------
-- The Serialise class

-- | Types that are instances of the @'Serialise'@ class allow values
-- to be quickly encoded or decoded directly to a CBOR representation,
-- for object transmission or storage.
--
-- @since 0.2.0.0
class Serialise a where
    -- | Definition for encoding a given type into a binary
    -- representation, using the @'Encoding'@ @'Monoid'@.
    --
    -- @since 0.2.0.0
    encode  :: a -> Encoding
    default encode :: (Generic a, GSerialiseEncode (Rep a)) => a -> Encoding
    encode = gencode . from

    -- | Definition of a given @'Decoder'@ for a type.
    --
    -- @since 0.2.0.0
    decode  :: Decoder s a
    default decode :: (Generic a, GSerialiseDecode (Rep a)) => Decoder s a
    decode = to <$> gdecode

    -- | Utility to support specialised encoding for some list type -
    -- used for @'Char'@/@'String'@ instances in this package.
    --
    -- @since 0.2.0.0
    encodeList :: [a] -> Encoding
    encodeList = defaultEncodeList

    -- | Utility to support specialised decoding for some list type -
    -- used for @'Char'@/@'String'@ instances in this package.
    --
    -- @since 0.2.0.0
    decodeList :: Decoder s [a]
    decodeList = defaultDecodeList

-- | @since 0.2.0.0
instance Serialise Term where
  encode = encodeTerm
  decode = decodeTerm

--------------------------------------------------------------------------------
-- Special list business

-- | @since 0.2.0.0
instance Serialise a => Serialise [a] where
    encode = encodeList
    decode = decodeList

-- | Default @'Encoding'@ for list types.
--
-- @since 0.2.0.0
defaultEncodeList :: Serialise a => [a] -> Encoding
defaultEncodeList [] = encodeListLen 0
defaultEncodeList xs = encodeListLenIndef
                    <> Prelude.foldr (\x r -> encode x <> r) encodeBreak xs

-- | Default @'Decoder'@ for list types.
--
-- @since 0.2.0.0
defaultDecodeList :: Serialise a => Decoder s [a]
defaultDecodeList = do
    mn <- decodeListLenOrIndef
    case mn of
      Nothing -> decodeSequenceLenIndef (flip (:)) [] reverse   decode
      Just n  -> decodeSequenceLenN     (flip (:)) [] reverse n decode

--------------------------------------------------------------------------------
-- Another case: NonEmpty lists

#if MIN_VERSION_base(4,9,0)
-- | @since 0.2.0.0
instance Serialise a => Serialise (NonEmpty.NonEmpty a) where
  encode = defaultEncodeList . NonEmpty.toList
  decode = do
    l <- defaultDecodeList
    case NonEmpty.nonEmpty l of
      Nothing -> fail "Expected a NonEmpty list, but an empty list was found!"
      Just xs -> return xs
#endif

--------------------------------------------------------------------------------
-- Primitive and integral instances

-- | @since 0.2.0.0
instance Serialise () where
    encode = const encodeNull
    decode = decodeNull

-- | @since 0.2.0.0
instance Serialise Bool where
    encode = encodeBool
    decode = decodeBool

-- | @since 0.2.0.0
instance Serialise Int where
    encode = encodeInt
    decode = decodeInt

-- | @since 0.2.0.0
instance Serialise Int8 where
    encode = encodeInt8
    decode = decodeInt8

-- | @since 0.2.0.0
instance Serialise Int16 where
    encode = encodeInt16
    decode = decodeInt16

-- | @since 0.2.0.0
instance Serialise Int32 where
    encode = encodeInt32
    decode = decodeInt32

-- | @since 0.2.0.0
instance Serialise Int64 where
    encode = encodeInt64
    decode = decodeInt64

-- | @since 0.2.0.0
instance Serialise Word where
    encode = encodeWord
    decode = decodeWord

-- | @since 0.2.0.0
instance Serialise Word8 where
    encode = encodeWord8
    decode = decodeWord8

-- | @since 0.2.0.0
instance Serialise Word16 where
    encode = encodeWord16
    decode = decodeWord16

-- | @since 0.2.0.0
instance Serialise Word32 where
    encode = encodeWord32
    decode = decodeWord32

-- | @since 0.2.0.0
instance Serialise Word64 where
    encode = encodeWord64
    decode = decodeWord64

-- | @since 0.2.0.0
instance Serialise Integer where
    encode = encodeInteger
    decode = decodeInteger

#if MIN_VERSION_base(4,8,0)
-- | @since 0.2.0.0
instance Serialise Natural where
    encode = encodeInteger . toInteger
    decode = do
      n <- decodeInteger
      if n >= 0
        then return (fromInteger n)
        else fail "Expected non-negative Natural; but got a negative number"
#endif

-- | @since 0.2.0.0
instance Serialise Float where
    encode = encodeFloat
    decode = decodeFloat

-- | @since 0.2.0.0
instance Serialise Double where
    encode = encodeDouble
    decode = decodeDouble

-- | @since 0.2.0.0
instance Serialise Half.Half where
    encode = encodeFloat16 . Half.fromHalf
    decode = fmap Half.toHalf decodeFloat

--------------------------------------------------------------------------------
-- Core types

#if MIN_VERSION_base(4,7,0)
-- | Values are serialised in units of least precision represented as
--   @Integer@.
--
-- @since 0.2.0.0
instance Serialise (Fixed e) where
    encode (MkFixed i) = encode i
    decode = MkFixed <$> decode

-- | @since 0.2.0.0
instance Serialise (Proxy a) where
    encode _ = encodeNull
    decode   = Proxy <$ decodeNull
#endif

-- | @since 0.2.0.0
instance Serialise Char where
    encode c = encodeString (Text.singleton c)
    decode = do t <- decodeString
                if Text.length t == 1
                  then return $! Text.head t
                  else fail "expected a single char, found a string"

    -- For [Char]/String we have a special encoding
    encodeList cs = encodeString (Text.pack cs)
    decodeList    = do txt <- decodeString
                       return (Text.unpack txt) -- unpack lazily

-- | @since 0.2.0.0
instance Serialise Text.Text where
    encode = encodeString
    decode = decodeString

-- | @since 0.2.0.0
instance Serialise BS.ByteString where
    encode = encodeBytes
    decode = decodeBytes

encodeChunked :: Serialise c
              => Encoding
              -> ((c -> Encoding -> Encoding) -> Encoding -> a -> Encoding)
              -> a
              -> Encoding
encodeChunked encodeIndef foldrChunks a =
    encodeIndef
 <> foldrChunks (\x r -> encode x <> r) encodeBreak a

decodeChunked :: Serialise c => Decoder s () -> ([c] -> a) -> Decoder s a
decodeChunked decodeIndef fromChunks = do
  decodeIndef
  decodeSequenceLenIndef (flip (:)) [] (fromChunks . reverse) decode

-- | @since 0.2.0.0
instance Serialise Text.Lazy.Text where
    encode = encodeChunked encodeStringIndef Text.Lazy.foldrChunks
    decode = decodeChunked decodeStringIndef Text.Lazy.fromChunks

-- | @since 0.2.0.0
instance Serialise BS.Lazy.ByteString where
    encode = encodeChunked encodeBytesIndef BS.Lazy.foldrChunks
    decode = decodeChunked decodeBytesIndef BS.Lazy.fromChunks

-- | @since 0.2.0.0
instance Serialise a => Serialise (Const a b) where
    encode (Const a) = encode a
    decode = Const <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (ZipList a) where
    encode (ZipList xs) = encode xs
    decode = ZipList <$> decode

-- | @since 0.2.0.0
instance (Serialise a, Integral a) => Serialise (Ratio a) where
    encode a = encodeListLen 2
            <> encode (numerator a)
            <> encode (denominator a)
    decode = do decodeListLenOf 2
                !a <- decode
                !b <- decode
                return $ a % b

-- | @since 0.2.0.0
instance Serialise a => Serialise (Complex a) where
    encode (r :+ i) = encodeListLen 2
                   <> encode r
                   <> encode i
    decode = do decodeListLenOf 2
                !r <- decode
                !i <- decode
                return $ r :+ i

-- | @since 0.2.0.0
instance Serialise Ordering where
    encode a = encodeListLen 1
            <> encodeWord (case a of LT -> 0
                                     EQ -> 1
                                     GT -> 2)
    decode = do
      decodeListLenOf 1
      t <- decodeWord
      case t of
        0 -> return LT
        1 -> return EQ
        2 -> return GT
        _ -> fail "unexpected tag"

-- | @since 0.2.0.0
instance Serialise a => Serialise (Down a) where
    encode (Down a) = encode a
    decode = Down <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Dual a) where
    encode (Dual a) = encode a
    decode = Dual <$> decode

-- | @since 0.2.0.0
instance Serialise All where
    encode (All b) = encode b
    decode = All <$> decode

-- | @since 0.2.0.0
instance Serialise Any where
    encode (Any b) = encode b
    decode = Any <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Sum a) where
    encode (Sum b) = encode b
    decode = Sum <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Product a) where
    encode (Product b) = encode b
    decode = Product <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (First a) where
    encode (First b) = encode b
    decode = First <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Last a) where
    encode (Last b) = encode b
    decode = Last <$> decode

#if MIN_VERSION_base(4,8,0)
-- | @since 0.2.0.0
instance Serialise (f a) => Serialise (Alt f a) where
    encode (Alt b) = encode b
    decode = Alt <$> decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Identity a) where
    encode (Identity b) = encode b
    decode = Identity <$> decode
#endif

-- | @since 0.2.0.0
instance Serialise ExitCode where
    encode ExitSuccess     = encodeListLen 1
                          <> encodeWord 0
    encode (ExitFailure i) = encodeListLen 2
                          <> encodeWord 1
                          <> encode i
    decode = do
      n <- decodeListLen
      case n of
        1 -> do t <- decodeWord
                case t of
                  0 -> return ExitSuccess
                  _ -> fail "unexpected tag"
        2 -> do t <- decodeWord
                case t of
                  1 -> return ()
                  _ -> fail "unexpected tag"
                !i <- decode
                return $ ExitFailure i
        _ -> fail "Bad list length"

-- Semigroup instances for GHC 8.0+
#if MIN_VERSION_base(4,9,0)
-- | @since 0.2.0.0
instance Serialise a => Serialise (Semigroup.Min a) where
  encode = encode . Semigroup.getMin
  decode = fmap Semigroup.Min decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Semigroup.Max a) where
  encode = encode . Semigroup.getMax
  decode = fmap Semigroup.Max decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Semigroup.First a) where
  encode = encode . Semigroup.getFirst
  decode = fmap Semigroup.First decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Semigroup.Last a) where
  encode = encode . Semigroup.getLast
  decode = fmap Semigroup.Last decode

-- | @since 0.2.0.0
instance Serialise a => Serialise (Semigroup.Option a) where
  encode = encode . Semigroup.getOption
  decode = fmap Semigroup.Option decode

instance Serialise a => Serialise (Semigroup.WrappedMonoid a) where
  encode = encode . Semigroup.unwrapMonoid
  decode = fmap Semigroup.WrapMonoid decode
#endif

--------------------------------------------------------------------------------
-- Foreign types

-- | @since 0.2.0.0
instance Serialise CChar where
    encode (CChar x) = encode x
    decode = CChar <$> decode

-- | @since 0.2.0.0
instance Serialise CSChar where
    encode (CSChar x) = encode x
    decode = CSChar <$> decode

-- | @since 0.2.0.0
instance Serialise CUChar where
    encode (CUChar x) = encode x
    decode = CUChar <$> decode

-- | @since 0.2.0.0
instance Serialise CShort where
    encode (CShort x) = encode x
    decode = CShort <$> decode

-- | @since 0.2.0.0
instance Serialise CUShort where
    encode (CUShort x) = encode x
    decode = CUShort <$> decode

-- | @since 0.2.0.0
instance Serialise CInt where
    encode (CInt x) = encode x
    decode = CInt <$> decode

-- | @since 0.2.0.0
instance Serialise CUInt where
    encode (CUInt x) = encode x
    decode = CUInt <$> decode

-- | @since 0.2.0.0
instance Serialise CLong where
    encode (CLong x) = encode x
    decode = CLong <$> decode

-- | @since 0.2.0.0
instance Serialise CULong where
    encode (CULong x) = encode x
    decode = CULong <$> decode

-- | @since 0.2.0.0
instance Serialise CPtrdiff where
    encode (CPtrdiff x) = encode x
    decode = CPtrdiff <$> decode

-- | @since 0.2.0.0
instance Serialise CSize where
    encode (CSize x) = encode x
    decode = CSize <$> decode

-- | @since 0.2.0.0
instance Serialise CWchar where
    encode (CWchar x) = encode x
    decode = CWchar <$> decode

-- | @since 0.2.0.0
instance Serialise CSigAtomic where
    encode (CSigAtomic x) = encode x
    decode = CSigAtomic <$> decode

-- | @since 0.2.0.0
instance Serialise CLLong where
    encode (CLLong x) = encode x
    decode = CLLong <$> decode

-- | @since 0.2.0.0
instance Serialise CULLong where
    encode (CULLong x) = encode x
    decode = CULLong <$> decode

-- | @since 0.2.0.0
instance Serialise CIntPtr where
    encode (CIntPtr x) = encode x
    decode = CIntPtr <$> decode

-- | @since 0.2.0.0
instance Serialise CUIntPtr where
    encode (CUIntPtr x) = encode x
    decode = CUIntPtr <$> decode

-- | @since 0.2.0.0
instance Serialise CIntMax where
    encode (CIntMax x) = encode x
    decode = CIntMax <$> decode

-- | @since 0.2.0.0
instance Serialise CUIntMax where
    encode (CUIntMax x) = encode x
    decode = CUIntMax <$> decode

-- | @since 0.2.0.0
instance Serialise CClock where
    encode (CClock x) = encode x
    decode = CClock <$> decode

-- | @since 0.2.0.0
instance Serialise CTime where
    encode (CTime x) = encode x
    decode = CTime <$> decode

-- | @since 0.2.0.0
instance Serialise CUSeconds where
    encode (CUSeconds x) = encode x
    decode = CUSeconds <$> decode

-- | @since 0.2.0.0
instance Serialise CSUSeconds where
    encode (CSUSeconds x) = encode x
    decode = CSUSeconds <$> decode

-- | @since 0.2.0.0
instance Serialise CFloat where
    encode (CFloat x) = encode x
    decode = CFloat <$> decode

-- | @since 0.2.0.0
instance Serialise CDouble where
    encode (CDouble x) = encode x
    decode = CDouble <$> decode

--------------------------------------------------------------------------------
-- Structural instances

-- | @since 0.2.0.0
instance (Serialise a, Serialise b) => Serialise (a,b) where
    encode (a,b) = encodeListLen 2
                <> encode a
                <> encode b
    decode = do decodeListLenOf 2
                !x <- decode
                !y <- decode
                return (x, y)

-- | @since 0.2.0.0
instance (Serialise a, Serialise b, Serialise c) => Serialise (a,b,c) where
    encode (a,b,c) = encodeListLen 3
                  <> encode a
                  <> encode b
                  <> encode c

    decode = do decodeListLenOf 3
                !x <- decode
                !y <- decode
                !z <- decode
                return (x, y, z)

-- | @since 0.2.0.0
instance (Serialise a, Serialise b, Serialise c, Serialise d
         ) => Serialise (a,b,c,d) where
    encode (a,b,c,d) = encodeListLen 4
                    <> encode a
                    <> encode b
                    <> encode c
                    <> encode d

    decode = do decodeListLenOf 4
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                return (a, b, c, d)

-- | @since 0.2.0.0
instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e
         ) => Serialise (a,b,c,d,e) where
    encode (a,b,c,d,e) = encodeListLen 5
                      <> encode a
                      <> encode b
                      <> encode c
                      <> encode d
                      <> encode e

    decode = do decodeListLenOf 5
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                !e <- decode
                return (a, b, c, d, e)

-- | @since 0.2.0.0
instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e
         , Serialise f
         ) => Serialise (a,b,c,d,e,f) where
    encode (a,b,c,d,e,f) = encodeListLen 6
                        <> encode a
                        <> encode b
                        <> encode c
                        <> encode d
                        <> encode e
                        <> encode f

    decode = do decodeListLenOf 6
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                !e <- decode
                !f <- decode
                return (a, b, c, d, e, f)

-- | @since 0.2.0.0
instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e
         , Serialise f, Serialise g
         ) => Serialise (a,b,c,d,e,f,g) where
    encode (a,b,c,d,e,f,g) = encodeListLen 7
                          <> encode a
                          <> encode b
                          <> encode c
                          <> encode d
                          <> encode e
                          <> encode f
                          <> encode g

    decode = do decodeListLenOf 7
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                !e <- decode
                !f <- decode
                !g <- decode
                return (a, b, c, d, e, f, g)

-- | @since 0.2.0.0
instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e
         , Serialise f, Serialise g, Serialise h
         ) => Serialise (a,b,c,d,e,f,g,h) where
    encode (a,b,c,d,e,f,g,h) = encodeListLen 8
                            <> encode a
                            <> encode b
                            <> encode c
                            <> encode d
                            <> encode e
                            <> encode f
                            <> encode g
                            <> encode h

    decode = do decodeListLenOf 8
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                !e <- decode
                !f <- decode
                !g <- decode
                !h <- decode
                return (a, b, c, d, e, f, g, h)

-- | @since 0.2.0.0
instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e
         , Serialise f, Serialise g, Serialise h, Serialise i
         ) => Serialise (a,b,c,d,e,f,g,h,i) where
    encode (a,b,c,d,e,f,g,h,i) = encodeListLen 9
                              <> encode a
                              <> encode b
                              <> encode c
                              <> encode d
                              <> encode e
                              <> encode f
                              <> encode g
                              <> encode h
                              <> encode i

    decode = do decodeListLenOf 9
                !a <- decode
                !b <- decode
                !c <- decode
                !d <- decode
                !e <- decode
                !f <- decode
                !g <- decode
                !h <- decode
                !i <- decode
                return (a, b, c, d, e, f, g, h, i)

-- | @since 0.2.0.0
instance Serialise a => Serialise (Maybe a) where
    encode Nothing  = encodeListLen 0
    encode (Just x) = encodeListLen 1 <> encode x

    decode = do n <- decodeListLen
                case n of
                  0 -> return Nothing
                  1 -> do !x <- decode
                          return (Just x)
                  _ -> fail "unknown tag"

-- | @since 0.2.0.0
instance (Serialise a, Serialise b) => Serialise (Either a b) where
    encode (Left  x) = encodeListLen 2 <> encodeWord 0 <> encode x
    encode (Right x) = encodeListLen 2 <> encodeWord 1 <> encode x

    decode = do decodeListLenOf 2
                t <- decodeWord
                case t of
                  0 -> do !x <- decode
                          return (Left x)
                  1 -> do !x <- decode
                          return (Right x)
                  _ -> fail "unknown tag"


--------------------------------------------------------------------------------
-- Container instances

-- | @since 0.2.0.0
instance Serialise a => Serialise (Tree.Tree a) where
  encode (Tree.Node r sub) = encodeListLen 2 <> encode r <> encode sub
  decode = decodeListLenOf 2 *> (Tree.Node <$> decode <*> decode)

encodeContainerSkel :: (Word -> Encoding)
                    -> (container -> Int)
                    -> (accumFunc -> Encoding -> container -> Encoding)
                    -> accumFunc
                    -> container
                    -> Encoding
encodeContainerSkel encodeLen size foldr f  c =
    encodeLen (fromIntegral (size c)) <> foldr f mempty c
{-# INLINE encodeContainerSkel #-}

decodeContainerSkelWithReplicate
  :: (Serialise a)
  => Decoder s Int
     -- ^ How to get the size of the container
  -> (Int -> Decoder s a -> Decoder s container)
     -- ^ replicateM for the container
  -> ([container] -> container)
     -- ^ concat for the container
  -> Decoder s container
decodeContainerSkelWithReplicate decodeLen replicateFun fromList = do
    -- Look at how much data we have at the moment and use it as the limit for
    -- the size of a single call to replicateFun. We don't want to use
    -- replicateFun directly on the result of decodeLen since this might lead to
    -- DOS attack (attacker providing a huge value for length). So if it's above
    -- our limit, we'll do manual chunking and then combine the containers into
    -- one.
    size <- decodeLen
    limit <- peekAvailable
    if size <= limit
       then replicateFun size decode
       else do
           -- Take the max of limit and a fixed chunk size (note: limit can be
           -- 0). This basically means that the attacker can make us allocate a
           -- container of size 128 even though there's no actual input.
           let chunkSize = max limit 128
               (d, m) = size `divMod` chunkSize
               buildOne s = replicateFun s decode
           containers <- sequence $ buildOne m : replicate d (buildOne chunkSize)
           return $! fromList containers
{-# INLINE decodeContainerSkelWithReplicate #-}

-- | @since 0.2.0.0
instance (Serialise a) => Serialise (Sequence.Seq a) where
  encode = encodeContainerSkel
             encodeListLen
             Sequence.length
             Foldable.foldr
             (\a b -> encode a <> b)
  decode = decodeContainerSkelWithReplicate
             decodeListLen
             Sequence.replicateM
             mconcat

-- | Generic encoder for vectors. Its intended use is to allow easy
-- definition of 'Serialise' instances for custom vector
--
-- @since 0.2.0.0
encodeVector :: (Serialise a, Vector.Generic.Vector v a)
             => v a -> Encoding
encodeVector = encodeContainerSkel
    encodeListLen
    Vector.Generic.length
    Vector.Generic.foldr
    (\a b -> encode a <> b)
{-# INLINE encodeVector #-}

-- | Generic decoder for vectors. Its intended use is to allow easy
-- definition of 'Serialise' instances for custom vector
--
-- @since 0.2.0.0
decodeVector :: (Serialise a, Vector.Generic.Vector v a)
             => Decoder s (v a)
decodeVector = decodeContainerSkelWithReplicate
    decodeListLen
    Vector.Generic.replicateM
    Vector.Generic.concat
{-# INLINE decodeVector #-}

-- | @since 0.2.0.0
instance (Serialise a) => Serialise (Vector.Vector a) where
  encode = encodeVector
  {-# INLINE encode #-}
  decode = decodeVector
  {-# INLINE decode #-}

-- | @since 0.2.0.0
instance (Serialise a, Vector.Unboxed.Unbox a) =>
         Serialise (Vector.Unboxed.Vector a) where
  encode = encodeVector
  {-# INLINE encode #-}
  decode = decodeVector
  {-# INLINE decode #-}

-- | @since 0.2.0.0
instance (Serialise a, Vector.Storable.Storable a) => Serialise (Vector.Storable.Vector a) where
  encode = encodeVector
  {-# INLINE encode #-}
  decode = decodeVector
  {-# INLINE decode #-}

-- | @since 0.2.0.0
instance (Serialise a, Vector.Primitive.Prim a) => Serialise (Vector.Primitive.Vector a) where
  encode = encodeVector
  {-# INLINE encode #-}
  decode = decodeVector
  {-# INLINE decode #-}



encodeSetSkel :: Serialise a
              => (s -> Int)
              -> ((a -> Encoding -> Encoding) -> Encoding -> s -> Encoding)
              -> s
              -> Encoding
encodeSetSkel size foldr =
    encodeContainerSkel encodeListLen size foldr (\a b -> encode a <> b)
{-# INLINE encodeSetSkel #-}

decodeSetSkel :: Serialise a
              => ([a] -> c) -> Decoder s c
decodeSetSkel fromList = do
  n <- decodeListLen
  fmap fromList (replicateM n decode)
{-# INLINE decodeSetSkel #-}

-- | @since 0.2.0.0
instance (Ord a, Serialise a) => Serialise (Set.Set a) where
  encode = encodeSetSkel Set.size Set.foldr
  decode = decodeSetSkel Set.fromList

-- | @since 0.2.0.0
instance Serialise IntSet.IntSet where
  encode = encodeSetSkel IntSet.size IntSet.foldr
  decode = decodeSetSkel IntSet.fromList

-- | @since 0.2.0.0
instance (Serialise a, Hashable a, Eq a) => Serialise (HashSet.HashSet a) where
  encode = encodeSetSkel HashSet.size HashSet.foldr
  decode = decodeSetSkel HashSet.fromList

encodeMapSkel :: (Serialise k, Serialise v)
              => (m -> Int)
              -> ((k -> v -> Encoding -> Encoding) -> Encoding -> m -> Encoding)
              -> m
              -> Encoding
encodeMapSkel size foldrWithKey =
  encodeContainerSkel
    encodeMapLen
    size
    foldrWithKey
    (\k v b -> encode k <> encode v <> b)
{-# INLINE encodeMapSkel #-}

decodeMapSkel :: (Serialise k, Serialise v)
              => ([(k,v)] -> m)
              -> Decoder s m
decodeMapSkel fromList = do
  n <- decodeMapLen
  let decodeEntry = do
        !k <- decode
        !v <- decode
        return (k, v)
  fmap fromList (replicateM n decodeEntry)
{-# INLINE decodeMapSkel #-}

-- | @since 0.2.0.0
instance (Ord k, Serialise k, Serialise v) => Serialise (Map.Map k v) where
  encode = encodeMapSkel Map.size Map.foldrWithKey
  decode = decodeMapSkel Map.fromList

-- | @since 0.2.0.0
instance (Serialise a) => Serialise (IntMap.IntMap a) where
  encode = encodeMapSkel IntMap.size IntMap.foldrWithKey
  decode = decodeMapSkel IntMap.fromList

-- | @since 0.2.0.0
instance (Serialise k, Hashable k, Eq k, Serialise v) =>
  Serialise (HashMap.HashMap k v) where
  encode = encodeMapSkel HashMap.size HashMap.foldrWithKey
  decode = decodeMapSkel HashMap.fromList


--------------------------------------------------------------------------------
-- Misc base package instances

-- | @since 0.2.0.0
instance Serialise Version where
    encode (Version ns ts) = encodeListLen 3
                          <> encodeWord 0 <> encode ns <> encode ts
    decode = do
      len <- decodeListLen
      tag <- decodeWord
      case tag of
        0 | len == 3
          -> do !x <- decode
                !y <- decode
                return (Version x y)
        _ -> fail "unexpected tag"

-- | @since 0.2.0.0
instance Serialise Fingerprint where
    encode (Fingerprint w1 w2) = encodeListLen 3
                              <> encodeWord 0
                              <> encode w1
                              <> encode w2
    decode = do
      decodeListLenOf 3
      tag <- decodeWord
      case tag of
        0 -> do !w1 <- decode
                !w2 <- decode
                return $! Fingerprint w1 w2
        _ -> fail "unexpected tag"

-- | @since 0.2.0.0
instance Serialise TyCon where
#if MIN_VERSION_base(4,10,0)
  encode tc
    = encodeListLen 6
   <> encodeWord 0
   <> encode (tyConPackage tc)
   <> encode (tyConModule tc)
   <> encode (tyConName tc)
   <> encode (tyConKindArgs tc)
   <> encode (tyConKindRep tc)
  decode = do
    decodeListLenOf 6
    tag <- decodeWord
    case tag of
      0 -> mkTyCon <$> decode <*> decode <*> decode <*> decode <*> decode
      _ -> fail "unexpected tag"
#elif MIN_VERSION_base(4,9,0)
  encode tycon
    = encodeListLen 4
   <> encodeWord 0
   <> encode (tyConPackage tycon)
   <> encode (tyConModule  tycon)
   <> encode (tyConName    tycon)
#else
  encode (TyCon _ pkg modname name)
    = encodeListLen 4
   <> encodeWord 0
   <> encode pkg
   <> encode modname
   <> encode name
#endif

#if !MIN_VERSION_base(4,10,0)
  decode = do
    decodeListLenOf 4
    tag <- decodeWord
    case tag of
      0 -> do !pkg     <- decode
              !modname <- decode
              !name    <- decode
              return $! mkTyCon3 pkg modname name
      _ -> fail "unexpected tag"
#endif

#if MIN_VERSION_base(4,10,0)
-- | @since 0.2.0.0
instance Serialise VecCount where
  encode c = encodeListLen 1 <> encodeWord (fromIntegral $ fromEnum c)
  decode = do
    decodeListLenOf 1
    toEnum . fromIntegral <$> decodeWord

-- | @since 0.2.0.0
instance Serialise VecElem where
  encode e = encodeListLen 1 <> encodeWord (fromIntegral $ fromEnum e)
  decode = do
    decodeListLenOf 1
    toEnum . fromIntegral <$> decodeWord

-- | @since 0.2.0.0
instance Serialise RuntimeRep where
  encode rr =
    case rr of
      VecRep a b    -> encodeListLen 3 <> encodeWord 0 <> encode a <> encode b
      TupleRep reps -> encodeListLen 2 <> encodeWord 1 <> encode reps
      SumRep reps   -> encodeListLen 2 <> encodeWord 2 <> encode reps
      LiftedRep     -> encodeListLen 1 <> encodeWord 3
      UnliftedRep   -> encodeListLen 1 <> encodeWord 4
      IntRep        -> encodeListLen 1 <> encodeWord 5
      WordRep       -> encodeListLen 1 <> encodeWord 6
      Int64Rep      -> encodeListLen 1 <> encodeWord 7
      Word64Rep     -> encodeListLen 1 <> encodeWord 8
      AddrRep       -> encodeListLen 1 <> encodeWord 9
      FloatRep      -> encodeListLen 1 <> encodeWord 10
      DoubleRep     -> encodeListLen 1 <> encodeWord 11

  decode = do
    len <- decodeListLen
    tag <- decodeWord
    case tag of
      0  | len == 3 -> VecRep <$> decode <*> decode
      1  | len == 2 -> TupleRep <$> decode
      2  | len == 2 -> SumRep <$> decode
      3  | len == 1 -> pure LiftedRep
      4  | len == 1 -> pure UnliftedRep
      5  | len == 1 -> pure IntRep
      6  | len == 1 -> pure WordRep
      7  | len == 1 -> pure Int64Rep
      8  | len == 1 -> pure Word64Rep
      9  | len == 1 -> pure AddrRep
      10 | len == 1 -> pure FloatRep
      11 | len == 1 -> pure DoubleRep
      _             -> fail "Data.Serialise.Binary.CBOR.getRuntimeRep: invalid tag"

-- | @since 0.2.0.0
instance Serialise KindRep where
  encode rep =
    case rep of
      KindRepTyConApp tc k  -> encodeListLen 3 <> encodeWord 0 <> encode tc <> encode k
      KindRepVar bndr       -> encodeListLen 2 <> encodeWord 1 <> encode bndr
      KindRepApp a b        -> encodeListLen 3 <> encodeWord 2 <> encode a <> encode b
      KindRepFun a b        -> encodeListLen 3 <> encodeWord 3 <> encode a <> encode b
      KindRepTYPE r         -> encodeListLen 2 <> encodeWord 4 <> encode r
      KindRepTypeLit sort r -> encodeListLen 3 <> encodeWord 5 <> encode sort <> encode r

  decode = do
    len <- decodeListLen
    tag <- decodeWord
    case tag of
      0 | len == 3 -> KindRepTyConApp <$> decode <*> decode
      1 | len == 2 -> KindRepVar <$> decode
      2 | len == 3 -> KindRepApp <$> decode <*> decode
      3 | len == 3 -> KindRepFun <$> decode <*> decode
      4 | len == 2 -> KindRepTYPE <$> decode
      5 | len == 3 -> KindRepTypeLit <$> decode <*> decode
      _            -> fail "Data.Serialise.Binary.CBOR.getKindRep: invalid tag"

-- | @since 0.2.0.0
instance Serialise TypeLitSort where
  encode n
    = encodeListLen 1
   <> case n of
        TypeLitSymbol -> encodeWord 0
        TypeLitNat    -> encodeWord 1
  decode = do
    decodeListLenOf 1
    tag <- decodeWord
    case tag of
      0 -> pure TypeLitSymbol
      1 -> pure TypeLitNat
      _ -> fail "Data.Serialise.Binary.CBOR.putTypeLitSort: invalid tag"

decodeSomeTypeRep :: Decoder s SomeTypeRep
decodeSomeTypeRep = do
    len <- decodeListLen
    tag <- decodeWord
    case tag of
      0 | len == 1 ->
              return $! SomeTypeRep (typeRep :: TypeRep Type)
      1 | len == 2 -> do
              !con <- decode
              !ks <- decode
              return $! SomeTypeRep $ mkTrCon con ks
      2 | len == 2 -> do
              SomeTypeRep f <- decodeSomeTypeRep
              SomeTypeRep x <- decodeSomeTypeRep
              case typeRepKind f of
                Fun arg res ->
                    case arg `eqTypeRep` typeRepKind x of
                      Just HRefl -> do
                          case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                            Just HRefl -> return $! SomeTypeRep (mkTrApp f x)
                            _          -> failure "Kind mismatch" []
                      _ -> failure "Kind mismatch"
                           [ "Found argument of kind:      " ++ show (typeRepKind x)
                           , "Where the constructor:       " ++ show f
                           , "Expects an argument of kind: " ++ show arg
                           ]
                _ -> failure "Applied non-arrow type"
                     [ "Applied type: " ++ show f
                     , "To argument:  " ++ show x
                     ]
      3 | len == 2 -> do
              SomeTypeRep arg <- decodeSomeTypeRep
              SomeTypeRep res <- decodeSomeTypeRep
              case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
                Just HRefl ->
                    case  typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                      Just HRefl -> return $! SomeTypeRep $ Fun arg res
                      Nothing -> failure "Kind mismatch" []
                Nothing -> failure "Kind mismatch" []
      _ -> failure "unexpected tag" []
  where
    failure description info =
        fail $ unlines $ [ "Codec.CBOR.Class.decodeSomeTypeRep: "++description ]
                         ++ map ("    "++) info

encodeTypeRep :: TypeRep a -> Encoding
encodeTypeRep rep  -- Handle Type specially since it's so common
  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
  = encodeListLen 1
 <> encodeWord 0
encodeTypeRep (Con' con ks)
  = encodeListLen 3
 <> encodeWord 1
 <> encode con
 <> encode ks
encodeTypeRep (App f x)
  = encodeListLen 3
 <> encodeWord 2
 <> encodeTypeRep f
 <> encodeTypeRep x
encodeTypeRep (Fun arg res)
  = encodeListLen 3
 <> encodeWord 3
 <> encodeTypeRep arg
 <> encodeTypeRep res
encodeTypeRep _ = error "Codec.CBOR.Class.encodeTypeRep: Impossible"

-- | @since 0.2.0.0
instance Typeable a => Serialise (TypeRep (a :: k)) where
  encode = encodeTypeRep
  decode = do
      SomeTypeRep rep <- decodeSomeTypeRep
      case rep `eqTypeRep` expected of
        Just HRefl -> pure rep
        Nothing    -> fail $ unlines
                      [ "Codec.CBOR.Class.decode(TypeRep): Type mismatch"
                      , "    Deserialized type: " ++ show rep
                      , "    Expected type:     " ++ show expected
                      ]
    where expected = typeRep :: TypeRep a

-- | @since 0.2.0.0
instance Serialise SomeTypeRep where
  encode (SomeTypeRep rep) = encodeTypeRep rep
  decode = decodeSomeTypeRep

#else

-- | @since 0.2.0.0
instance Serialise TypeRep where
#if MIN_VERSION_base(4,8,0)
  encode (TypeRep fp tycon kirep tyrep)
    = encodeListLen 5
   <> encodeWord 0
   <> encode fp
   <> encode tycon
   <> encode kirep
   <> encode tyrep

  decode = do
    decodeListLenOf 5
    tag <- decodeWord
    case tag of
      0 -> do !fp    <- decode
              !tycon <- decode
              !kirep <- decode
              !tyrep <- decode
              return $! TypeRep fp tycon kirep tyrep
      _ -> fail "unexpected tag"
#else
  encode (TypeRep fp tycon tyrep)
    = encodeListLen 4
   <> encodeWord 0
   <> encode fp
   <> encode tycon
   <> encode tyrep

  decode = do
    decodeListLenOf 4
    tag <- decodeWord
    case tag of
      0 -> do !fp    <- decode
              !tycon <- decode
              !tyrep <- decode
              return $! TypeRep fp tycon tyrep
      _ -> fail "unexpected tag"
#endif

#endif /* !MIN_VERBOSE_base(4,10,0) */

--------------------------------------------------------------------------------
-- Time instances
--
-- CBOR has some special encodings for times/timestamps

-- | 'UTCTime' is encoded using the extended time format which is currently in
-- Internet Draft state,
-- https://tools.ietf.org/html/draft-bormann-cbor-time-tag-00.
--
-- @since 0.2.0.0
instance Serialise UTCTime where
    encode t =
        encodeTag 1000
        <> encodeMapLen 2
        <> encodeWord 1 <> encodeInt64 secs
        <> encodeInt (-12) <> encodeWord64 psecs
      where
        (secs, frac) = case properFraction $ utcTimeToPOSIXSeconds t of
                         -- fractional part must be positive
                         (secs', frac')
                           | frac' < 0  -> (secs' - 1, frac' + 1)
                           | otherwise -> (secs', frac')
        psecs = round $ frac * 1000000000000

    decode = do
      tag <- decodeTag
      case tag of
        0 -> do str <- decodeString
                case parseUTCrfc3339 (Text.unpack str) of
                  Just t  -> return $! forceUTCTime t
                  Nothing -> fail "Could not parse RFC3339 date"

        1 -> do
          tt <- peekTokenType
          case tt of
            TypeUInt    -> utcFromIntegral <$> decodeWord
            TypeUInt64  -> utcFromIntegral <$> decodeWord64
            TypeNInt    -> utcFromIntegral <$> decodeInt
            TypeNInt64  -> utcFromIntegral <$> decodeInt64
            TypeInteger -> utcFromIntegral <$> decodeInteger
            TypeFloat16 -> utcFromReal <$> decodeFloat
            TypeFloat32 -> utcFromReal <$> decodeFloat
            TypeFloat64 -> utcFromReal <$> decodeDouble
            _ -> fail "Expected numeric type following tag 1 (epoch offset)"

        -- Extended time
        1000 -> do
          len <- decodeMapLen
          when (len /= 2) $ fail "Expected list of length two (UTCTime)"

          k0 <- decodeInt
          when (k0 /= 1) $ fail "Expected key 1 in extended time"
          v0 <- decodeInt64

          k1 <- decodeInt
          when (k1 /= (-12)) $ fail "Expected key -12 in extended time"
          v1 <- decodeWord64
          let psecs :: Pico
              psecs = realToFrac v1 / 1000000000000

              dt :: POSIXTime
              dt = realToFrac v0 + realToFrac psecs
          return $! forceUTCTime (posixSecondsToUTCTime dt)

        _ -> fail "Expected timestamp (tag 0, 1, or 40)"

epoch :: UTCTime
epoch = UTCTime (fromGregorian 1970 1 1) 0

{-# INLINE utcFromIntegral #-}
utcFromIntegral :: Integral a => a -> UTCTime
utcFromIntegral i = addUTCTime (fromIntegral i) epoch

{-# INLINE utcFromReal #-}
utcFromReal :: Real a => a -> UTCTime
utcFromReal f = addUTCTime (fromRational (toRational f)) epoch


-- | @'UTCTime'@ parsing, from a regular @'String'@.
parseUTCrfc3339  :: String -> Maybe UTCTime
#if MIN_VERSION_time(1,5,0)
parseUTCrfc3339  = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z"
#else
parseUTCrfc3339  = parseTime        defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z"
#endif

-- | Force the unnecessarily lazy @'UTCTime'@ representation.
forceUTCTime :: UTCTime -> UTCTime
forceUTCTime t@(UTCTime !_day !_daytime) = t

--------------------------------------------------------------------------------
-- Generic instances

-- Factored into two classes because this makes GHC optimize the
-- instances faster. This doesn't matter for builds of binary, but it
-- matters a lot for end-users who write 'instance Binary T'. See
-- also: https://ghc.haskell.org/trac/ghc/ticket/9630

-- | @since 0.2.0.0
class GSerialiseEncode f where
    -- | @since 0.2.0.0
    gencode  :: f a -> Encoding

-- | @since 0.2.0.0
class GSerialiseDecode f where
    -- | @since 0.2.0.0
    gdecode  :: Decoder s (f a)

-- | @since 0.2.0.0
instance GSerialiseEncode V1 where
    -- Data types without constructors are still serialised as null value
    gencode _ = encodeNull

-- | @since 0.2.0.0
instance GSerialiseDecode V1 where
    gdecode   = error "V1 don't have contructors" <$ decodeNull

-- | @since 0.2.0.0
instance GSerialiseEncode U1 where
    -- Constructors without fields are serialised as null value
    gencode _ = encodeListLen 1 <> encodeWord 0

-- | @since 0.2.0.0
instance GSerialiseDecode U1 where
    gdecode   = do
      n <- decodeListLen
      when (n /= 1) $ fail "expect list of length 1"
      tag <- decodeWord
      when (tag /= 0) $ fail "unexpected tag. Expect 0"
      return U1

-- | @since 0.2.0.0
instance GSerialiseEncode a => GSerialiseEncode (M1 i c a) where
    -- Metadata (constructor name, etc) is skipped
    gencode = gencode . unM1

-- | @since 0.2.0.0
instance GSerialiseDecode a => GSerialiseDecode (M1 i c a) where
    gdecode = M1 <$> gdecode

-- | @since 0.2.0.0
instance Serialise a => GSerialiseEncode (K1 i a) where
    -- Constructor field (Could only appear in one-field & one-constructor
    -- data types). In all other cases we go through GSerialise{Sum,Prod}
    gencode (K1 a) = encodeListLen 2
                  <> encodeWord 0
                  <> encode a

-- | @since 0.2.0.0
instance Serialise a => GSerialiseDecode (K1 i a) where
    gdecode = do
      n <- decodeListLen
      when (n /= 2) $
        fail "expect list of length 2"
      tag <- decodeWord
      when (tag /= 0) $
        fail "unexpected tag. Expects 0"
      K1 <$> decode

-- | @since 0.2.0.0
instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseEncode (f :*: g) where
    -- Products are serialised as N-tuples with 0 constructor tag
    gencode (f :*: g)
        = encodeListLen (nFields (Proxy :: Proxy (f :*: g)) + 1)
       <> encodeWord 0
       <> encodeSeq f
       <> encodeSeq g

-- | @since 0.2.0.0
instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseDecode (f :*: g) where
    gdecode = do
      let nF = nFields (Proxy :: Proxy (f :*: g))
      n <- decodeListLen
      -- TODO FIXME: signedness of list length
      when (fromIntegral n /= nF + 1) $
        fail $ "Wrong number of fields: expected="++show (nF+1)++" got="++show n
      tag <- decodeWord
      when (tag /= 0) $
        fail $ "unexpect tag (expect 0)"
      !f <- gdecodeSeq
      !g <- gdecodeSeq
      return $ f :*: g

-- | @since 0.2.0.0
instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseEncode (f :+: g) where
    -- Sum types are serialised as N-tuples and first element is
    -- constructor tag
    gencode a = encodeListLen (numOfFields a + 1)
             <> encode (conNumber a)
             <> encodeSum a

-- | @since 0.2.0.0
instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseDecode (f :+: g) where
    gdecode = do
        n <- decodeListLen
        -- TODO FIXME: Again signedness
        when (n == 0) $
          fail "Empty list encountered for sum type"
        nCon  <- decodeWord
        trueN <- fieldsForCon (Proxy :: Proxy (f :+: g)) nCon
        when (n-1 /= fromIntegral trueN ) $
          fail $ "Number of fields mismatch: expected="++show trueN++" got="++show n
        decodeSum nCon


-- | Serialization of product types
class GSerialiseProd f where
    -- | Number of fields in product type
    nFields   :: Proxy f -> Word
    -- | Encode fields sequentially without writing header
    encodeSeq :: f a -> Encoding
    -- | Decode fields sequentially without reading header
    gdecodeSeq :: Decoder s (f a)

-- | @since 0.2.0.0
instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseProd (f :*: g) where
    nFields _ = nFields (Proxy :: Proxy f) + nFields (Proxy :: Proxy g)
    encodeSeq (f :*: g) = encodeSeq f <> encodeSeq g
    gdecodeSeq = do !f <- gdecodeSeq
                    !g <- gdecodeSeq
                    return (f :*: g)

-- | @since 0.2.0.0
instance GSerialiseProd U1 where
    -- N.B. Could only be reached when one of constructors in sum type
    --      don't have parameters
    nFields   _ = 0
    encodeSeq _ = mempty
    gdecodeSeq  = return U1

-- | @since 0.2.0.0
instance (Serialise a) => GSerialiseProd (K1 i a) where
    -- Ordinary field
    nFields    _     = 1
    encodeSeq (K1 f) = encode f
    gdecodeSeq       = K1 <$> decode

-- | @since 0.2.0.0
instance (i ~ S, GSerialiseProd f) => GSerialiseProd (M1 i c f) where
    -- We skip metadata
    nFields     _     = 1
    encodeSeq  (M1 f) = encodeSeq f
    gdecodeSeq        = M1 <$> gdecodeSeq

-- | Serialization of sum types
--
-- @since 0.2.0.0
class GSerialiseSum f where
    -- | Number of constructor of given value
    conNumber   :: f a -> Word
    -- | Number of fields of given value
    numOfFields :: f a -> Word
    -- | Encode field
    encodeSum   :: f a  -> Encoding

    -- | Decode field
    decodeSum     :: Word -> Decoder s (f a)
    -- | Number of constructors
    nConstructors :: Proxy f -> Word
    -- | Number of fields for given constructor number
    fieldsForCon  :: Proxy f -> Word -> Decoder s Word

-- | @since 0.2.0.0
instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseSum (f :+: g) where
    conNumber x = case x of
      L1 f -> conNumber f
      R1 g -> conNumber g + nConstructors (Proxy :: Proxy f)
    numOfFields x = case x of
      L1 f -> numOfFields f
      R1 g -> numOfFields g
    encodeSum x = case x of
      L1 f -> encodeSum f
      R1 g -> encodeSum g

    nConstructors _ = nConstructors (Proxy :: Proxy f)
                    + nConstructors (Proxy :: Proxy g)

    fieldsForCon _ n | n < nL    = fieldsForCon (Proxy :: Proxy f) n
                     | otherwise = fieldsForCon (Proxy :: Proxy g) (n - nL)
      where
        nL = nConstructors (Proxy :: Proxy f)

    decodeSum nCon | nCon < nL = L1 <$> decodeSum nCon
                   | otherwise = R1 <$> decodeSum (nCon - nL)
      where
        nL = nConstructors (Proxy :: Proxy f)

-- | @since 0.2.0.0
instance (i ~ C, GSerialiseProd f) => GSerialiseSum (M1 i c f) where
    conNumber    _     = 0
    numOfFields  _     = nFields (Proxy :: Proxy f)
    encodeSum   (M1 f) = encodeSeq f

    nConstructors  _ = 1
    fieldsForCon _ 0 = return $ nFields (Proxy :: Proxy f)
    fieldsForCon _ _ = fail "Bad constructor number"
    decodeSum      0 = M1 <$> gdecodeSeq
    decodeSum      _ = fail "bad constructor number"