content: {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE TypeFamilies          #-}
  
  module Node.Message.Binary
      ( BinaryP
      , binaryP
      , binaryPacking
      , binaryPackMsg
      , binaryUnpackMsg
      ) where
  
  import qualified Data.Binary as Bin
  import qualified Data.Binary.Get as Bin
  import qualified Data.Binary.Put as Bin
  import qualified Data.ByteString.Builder.Extra as BS
  import qualified Data.ByteString.Lazy as LBS
  import           Data.Functor.Identity (Identity (..))
  import           Data.Proxy (Proxy (..))
  import qualified Data.Text as T
  import           Node.Message.Class (Packing (..), PackingType (..),
                       Serializable (..))
  import           Node.Message.Decoder (Decoder (..), DecoderStep (..))
  
  data BinaryP
  
  binaryP :: Proxy BinaryP
  binaryP = Proxy
  
  -- | BinaryP packing works in any Applicative.
  binaryPacking :: ( Applicative m ) => Packing BinaryP m
  binaryPacking = Packing
      { packingType = binaryP
      , packM = pure . runIdentity
      , unpackM = pure . runIdentity
      }
  
  instance PackingType BinaryP where
      type PackM BinaryP = Identity
      type UnpackM BinaryP = Identity
  
  binaryPackMsg :: Bin.Put -> LBS.ByteString
  binaryPackMsg =
      BS.toLazyByteStringWith
          (BS.untrimmedStrategy 256 4096)
          LBS.empty
      . Bin.execPut
  
  binaryUnpackMsg :: Bin.Get t -> Decoder (UnpackM BinaryP) t
  binaryUnpackMsg get = Decoder (pure (fromBinaryDecoder (Bin.runGetIncremental get)))
  
  fromBinaryDecoder :: Bin.Decoder t -> DecoderStep (UnpackM BinaryP) t
  fromBinaryDecoder (Bin.Done bs bo t)   = Done bs bo t
  fromBinaryDecoder (Bin.Fail bs bo err) = Fail bs bo (T.pack err)
  fromBinaryDecoder (Bin.Partial k)      = Partial (Decoder . pure . fromBinaryDecoder . k)
  
  instance ( Bin.Binary t ) => Serializable BinaryP t where
      packMsg _ = pure . binaryPackMsg . Bin.put
      unpackMsg _ = binaryUnpackMsg Bin.get
  