content: {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
      ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      : Distribution.Compat.Binary.Generic
  -- Copyright   : Bryan O'Sullivan
  -- License     : BSD3-style (see LICENSE)
  --
  -- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>
  -- Stability   : unstable
  -- Portability : Only works with GHC 7.2 and newer
  --
  -- Instances for supporting GHC generics.
  --
  -----------------------------------------------------------------------------
  module Distribution.Compat.Binary.Generic
      (
      ) where
  
  import Control.Applicative
  import Distribution.Compat.Binary.Class
  import Data.Binary.Get
  import Data.Binary.Put
  import Data.Bits
  import Data.Word
  import GHC.Generics
  
  -- Type without constructors
  instance GBinary V1 where
      gput _ = return ()
      gget   = return undefined
  
  -- Constructor without arguments
  instance GBinary U1 where
      gput U1 = return ()
      gget    = return U1
  
  -- Product: constructor with parameters
  instance (GBinary a, GBinary b) => GBinary (a :*: b) where
      gput (x :*: y) = gput x >> gput y
      gget = (:*:) <$> gget <*> gget
  
  -- Metadata (constructor name, etc)
  instance GBinary a => GBinary (M1 i c a) where
      gput = gput . unM1
      gget = M1 <$> gget
  
  -- Constants, additional parameters, and rank-1 recursion
  instance Binary a => GBinary (K1 i a) where
      gput = put . unK1
      gget = K1 <$> get
  
  -- Borrowed from the cereal package.
  
  -- The following GBinary instance for sums has support for serializing
  -- types with up to 2^64-1 constructors. It will use the minimal
  -- number of bytes needed to encode the constructor. For example when
  -- a type has 2^8 constructors or less it will use a single byte to
  -- encode the constructor. If it has 2^16 constructors or less it will
  -- use two bytes, and so on till 2^64-1.
  
  #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
  #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
  #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
  
  instance ( GSum     a, GSum     b
           , GBinary a, GBinary b
           , SumSize    a, SumSize    b) => GBinary (a :+: b) where
      gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
           | otherwise = sizeError "encode" size
        where
          size = unTagged (sumSize :: Tagged (a :+: b) Word64)
  
      gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
           | otherwise = sizeError "decode" size
        where
          size = unTagged (sumSize :: Tagged (a :+: b) Word64)
  
  sizeError :: Show size => String -> size -> error
  sizeError s size =
      error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"
  
  ------------------------------------------------------------------------
  
  checkGetSum :: (Ord word, Num word, Bits word, GSum f)
              => word -> word -> Get (f a)
  checkGetSum size code | code < size = getSum code size
                        | otherwise   = fail "Unknown encoding for constructor"
  {-# INLINE checkGetSum #-}
  
  class GSum f where
      getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
      putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
  
  instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
      getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL
                         | otherwise    = R1 <$> getSum (code - sizeL) sizeR
          where
            sizeL = size `shiftR` 1
            sizeR = size - sizeL
  
      putSum !code !size s = case s of
                               L1 x -> putSum code           sizeL x
                               R1 x -> putSum (code + sizeL) sizeR x
          where
            sizeL = size `shiftR` 1
            sizeR = size - sizeL
  
  instance GBinary a => GSum (C1 c a) where
      getSum _ _ = gget
  
      putSum !code _ x = put code *> gput x
  
  ------------------------------------------------------------------------
  
  class SumSize f where
      sumSize :: Tagged f Word64
  
  newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}
  
  instance (SumSize a, SumSize b) => SumSize (a :+: b) where
      sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
                         unTagged (sumSize :: Tagged b Word64)
  
  instance SumSize (C1 c a) where
      sumSize = Tagged 1
  