{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Deserialization monad and deserializable types.
module Data.Deserializer
  (
  -- * Deserialization monad
    Deserializer(..)
  , BinaryDeserializer(..)
  , CerealDeserializer(..)
  -- ** Binary word parsing
  , word16H
  , word32H
  , word64H
  , word
  , wordL
  , wordB
  , wordH
  , int8
  , int16
  , int16L
  , int16B
  , int16H
  , int32
  , int32L
  , int32B
  , int32H
  , int64
  , int64L
  , int64B
  , int64H
  , int
  , intL
  , intB
  , intH
  -- ** Parsing combinators
  , module Text.Parser.Combinators
  , label
  , module Text.Parser.LookAhead
  -- ** Endian deserializers
  , LittleEndianDeserializer(..)
  , BigEndianDeserializer(..)
  , deserializeIn
  , deserializeH
  -- ** Default deserializer
  , Deserialized(..)
  , isDeserialized
  , isMalformed
  , maybeDeserialized
  , defaultDeserializer
  -- * Deserializable types
  , Deserializable(..)
  , getIn
  , getL
  , getB
  , getH
  , deserializeBytes
  , deserializeBytesAs
  , deserializeByteString
  , deserializeByteStringAs
  , deserializeLazyByteString
  , deserializeLazyByteStringAs
  , fromBytes
  , fromBytesAs
  , fromByteString
  , fromByteStringAs
  , fromLazyByteString
  , fromLazyByteStringAs
  , RestDeserializable(..)
  ) where

import Prelude hiding (take)
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.Data (Data)
import Data.Proxy (Proxy(..))
import Data.Endian (Endian(..), swapEndian)
import Data.Word
import Data.Int
import Data.Bits ((.|.), shiftL)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Short as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Builder as BB
import qualified Data.Binary.Get as B
import qualified Data.Binary.Get.Internal as B
import qualified Data.Serialize.Get as S
import Data.List.Split (splitOn)
import Text.Parser.Combinators
import Text.Parser.LookAhead
import Control.Applicative (Applicative(..), Alternative,
                            (<$>), (<$), (<*>), (*>), (<|>))
import Control.Monad (unless)

-- | Deserialization monad.
class (Monad μ, Parsing μ) ⇒ Deserializer μ where
  {-# MINIMAL ensure, take, chunk, isolate #-}
  -- | Default byte order of the deserializer.
  endian ∷ Proxy μ → Endian
#ifdef WORDS_BIGENDIAN
  endian _ = BigEndian
#else
  endian _ = LittleEndian
#endif
  -- | Deserialze a byte.
  word8 ∷ μ Word8
  word8 = BS.unsafeHead <$> take 1 <?> "word8"
  {-# INLINE word8 #-}
  -- | Deserialize an unsigned 16-bit integer in default byte order.
  word16 ∷ μ Word16
  word16 = getIn (endian (Proxy ∷ Proxy μ))
  {-# INLINE word16 #-}
  -- | Deserialize an unsigned 32-bit integer in default byte order.
  word32 ∷ μ Word32
  word32 = getIn (endian (Proxy ∷ Proxy μ))
  {-# INLINE word32 #-}
  -- | Deserialize an unsigned 64-bit integer in default byte order.
  word64 ∷ μ Word64
  word64 = getIn (endian (Proxy ∷ Proxy μ))
  {-# INLINE word64 #-}
  -- | Deserialize an unsigned 16-bit integer in little endian.
  word16L ∷ μ Word16
  word16L = (<?> "word16")
          $ do bs ← take 2
               let l = BS.unsafeIndex bs 0
                   h = BS.unsafeIndex bs 1
               return $ shiftL (fromIntegral h) 8 .|. fromIntegral l
  -- | Deserialize an unsigned 16-bit integer in big endian.
  word16B ∷ μ Word16
  word16B = swapEndian <$> word16L
  -- | Deserialize an unsigned 32-bit integer in little endian.
  word32L ∷ μ Word32
  word32L = (<?> "word32")
          $ do bs ← take 4
               let o₀ = BS.unsafeIndex bs 0
                   o₁ = BS.unsafeIndex bs 1
                   o₂ = BS.unsafeIndex bs 2
                   o₃ = BS.unsafeIndex bs 3
               return  $  shiftL (fromIntegral o₃) 24
                      .|. shiftL (fromIntegral o₂) 16
                      .|. shiftL (fromIntegral o₁) 8
                      .|. fromIntegral o₀
  -- | Deserialize an unsigned 32-bit integer in big endian.
  word32B ∷ μ Word32
  word32B = swapEndian <$> word32L
  -- | Deserialize an unsigned 64-bit integer in little endian.
  word64L ∷ μ Word64
  word64L = (<?> "word64")
          $ do bs ← take 8
               let o₀ = BS.unsafeIndex bs 0
                   o₁ = BS.unsafeIndex bs 1
                   o₂ = BS.unsafeIndex bs 2
                   o₃ = BS.unsafeIndex bs 3
                   o₄ = BS.unsafeIndex bs 4
                   o₅ = BS.unsafeIndex bs 5
                   o₆ = BS.unsafeIndex bs 6
                   o₇ = BS.unsafeIndex bs 7
               return  $  shiftL (fromIntegral o₇) 56
                      .|. shiftL (fromIntegral o₆) 48
                      .|. shiftL (fromIntegral o₅) 40
                      .|. shiftL (fromIntegral o₄) 32
                      .|. shiftL (fromIntegral o₃) 24
                      .|. shiftL (fromIntegral o₂) 16
                      .|. shiftL (fromIntegral o₁) 8
                      .|. fromIntegral o₀
  -- | Deserialize an unsigned 64-bit integer in big endian.
  word64B ∷ μ Word64
  word64B = swapEndian <$> word64L
  -- | 'satisfy' /p/ deserializes a byte that satisfies the predicate /p/,
  --   failing otherwise.
  satisfy ∷ (Word8 → Bool) → μ Word8
  satisfy p = do w ← word8
                 if p w then return w
                        else unexpected (show w)
  {-# INLINE satisfy #-}
  -- | Deserialize the specified byte value, failing on any other input.
  byte ∷ Word8 → μ Word8
  byte w = (<?> "byte " ++ show w)
         $ do w' ← word8
              if w' == w then return w'
                         else unexpected (show w')
  {-# INLINE byte #-}
  -- | 'notByte' /c/ deserializes any byte that is not equal to /c/, failing
  --   if /c/ is encountered.
  notByte ∷ Word8 → μ Word8
  notByte w = (<?> "not byte " ++ show w)
            $ do w' ← word8
                 if w' == w then unexpected (show w')
                            else return w'
  {-# INLINE notByte #-}
  -- | 'bytes' /bs/ deserializes a sequence of bytes given by /bs/, failing
  --   on any other input.
  bytes ∷ BS.ByteString → μ BS.ByteString
  bytes bs = (<?> "bytes " ++ show (BS.unpack bs))
           $ do bs' ← take (BS.length bs)
                if bs' == bs then return bs'
                             else unexpected (show $ BS.unpack bs')
  {-# INLINE bytes #-}
  -- | Skip exactly the given number of bytes.
  skip ∷ Int → μ ()
  skip n | n <= 0    = pure ()
         | otherwise = word8 *> skip (n - 1)
  -- | 'ensure' /n/ checks that the input has at least /n/ more bytes and
  --   returns a portion of the input of length greater or equal to /n/
  --   (without consuming it).
  ensure ∷ Int → μ BS.ByteString
  -- | 'ensure_' /n/ fails if the input has less than /n/ more bytes.
  ensure_ ∷ Int → μ ()
  ensure_ = (() <$) . ensure
  {-# INLINE ensure_ #-}
  -- | Consume exactly the given number of bytes.
  take ∷ Int → μ BS.ByteString
  -- | Consume a portion of the input (the size of the returned
  --   'BS.ByteString' is implementation dependent). Empty result means that
  --    the 'eof' is reached.
  chunk ∷ μ BS.ByteString
  -- | 'isolate' /n/ /d/ feeds the next /n/ bytes to the deserializer /d/.
  --   If /d/ consumes less or more that /n/ bytes, 'isolate' will fail.
  isolate ∷ Int → μ α → μ α

-- | A wrapper around the 'B.Get' monad (to avoid orphan instances).
newtype BinaryDeserializer α =
          BinaryDeserializer { binaryDeserializer ∷ B.Get α }
          deriving (Typeable, Generic, Functor, Applicative,
                    Alternative, Monad)

instance Parsing BinaryDeserializer where
  try p = p
  {-# INLINE try #-}
  p <?> l = BinaryDeserializer (B.label l (binaryDeserializer p))
  {-# INLINE (<?>) #-}
  skipMany p = ((True <$ p) <|> pure False) >>= \case
                 True  → skipMany p
                 False → return ()
  unexpected = fail
  {-# INLINE unexpected #-}
  eof = BinaryDeserializer
      $ B.isEmpty >>= \case
          True  → return ()
          False → fail "Parsing.eof"
  {-# INLINABLE eof #-}
  notFollowedBy p = BinaryDeserializer
                  $ (B.lookAheadE (Left <$> (binaryDeserializer p)) <|>
                     pure (Right ())) >>= \case
                      Left e  → fail (show e)
                      Right _ → return ()
  {-# INLINABLE notFollowedBy #-}

instance LookAheadParsing BinaryDeserializer where
  lookAhead = BinaryDeserializer . B.lookAhead . binaryDeserializer
  {-# INLINE lookAhead #-}

instance Deserializer BinaryDeserializer where
  word8 = BinaryDeserializer B.getWord8
  {-# INLINE word8 #-}
  word16L = BinaryDeserializer B.getWord16le
  {-# INLINE word16L #-}
  word16B = BinaryDeserializer B.getWord16be
  {-# INLINE word16B #-}
  word32L = BinaryDeserializer B.getWord32le
  {-# INLINE word32L #-}
  word32B = BinaryDeserializer B.getWord32be
  {-# INLINE word32B #-}
  word64L = BinaryDeserializer B.getWord64le
  {-# INLINE word64L #-}
  word64B = BinaryDeserializer B.getWord64be
  {-# INLINE word64B #-}
  skip = BinaryDeserializer . B.skip
  {-# INLINE skip #-}
  ensure n = BinaryDeserializer (B.ensureN n *> B.get)
  {-# INLINE ensure #-}
  ensure_ = BinaryDeserializer . B.ensureN
  {-# INLINE ensure_ #-}
  take = BinaryDeserializer . B.getByteString
  {-# INLINE take #-}
  chunk = BinaryDeserializer
        $ do bs ← B.get
             if BS.null bs
             then do
               e ← B.isEmpty
               if e
               then return bs
               else B.get
             else
               return bs
  {-# INLINABLE chunk #-}
  isolate n d = BinaryDeserializer $ B.isolate n (binaryDeserializer d)
  {-# INLINE isolate #-}

-- | A wrapper around the 'S.Get' monad (to avoid orphan instances).
newtype CerealDeserializer α =
          CerealDeserializer { cerealDeserializer ∷ S.Get α }
          deriving (Typeable, Generic,  Functor, Applicative,
                    Alternative, Monad)

instance Parsing CerealDeserializer where
  try p = p
  {-# INLINE try #-}
  p <?> l = CerealDeserializer (S.label l (cerealDeserializer p))
  {-# INLINE (<?>) #-}
  skipMany p = ((True <$ p) <|> pure False) >>= \case
                 True  → skipMany p
                 False → return ()
  unexpected = fail
  {-# INLINE unexpected #-}
  eof = CerealDeserializer
      $ ((False <$ S.lookAheadM (Nothing <$ S.getWord8)) <|>
         pure True) >>= \case
          True  → return ()
          False → fail "Parsing.eof"
  {-# INLINABLE eof #-}
  notFollowedBy p = CerealDeserializer
                  $ (S.lookAheadE (Left <$> (cerealDeserializer p)) <|>
                     pure (Right ())) >>= \case
                      Left e  → fail (show e)
                      Right _ → return ()
  {-# INLINABLE notFollowedBy #-}

instance LookAheadParsing CerealDeserializer where
  lookAhead = CerealDeserializer . S.lookAhead . cerealDeserializer
  {-# INLINE lookAhead #-}

instance Deserializer CerealDeserializer where
  word8 = CerealDeserializer S.getWord8
  {-# INLINE word8 #-}
  word16L = CerealDeserializer S.getWord16le
  {-# INLINE word16L #-}
  word16B = CerealDeserializer S.getWord16be
  {-# INLINE word16B #-}
  word32L = CerealDeserializer S.getWord32le
  {-# INLINE word32L #-}
  word32B = CerealDeserializer S.getWord32be
  {-# INLINE word32B #-}
  word64L = CerealDeserializer S.getWord64le
  {-# INLINE word64L #-}
  word64B = CerealDeserializer S.getWord64be
  {-# INLINE word64B #-}
  skip = CerealDeserializer . S.skip
  {-# INLINE skip #-}
  ensure = CerealDeserializer . S.ensure
  {-# INLINE ensure #-}
  take = CerealDeserializer . S.getBytes
  {-# INLINE take #-}
  chunk = CerealDeserializer
        $ (<|> pure BS.empty)
        $ do bs ← S.ensure 1
             S.uncheckedSkip (BS.length bs)
             return bs
  {-# INLINE chunk #-}
  isolate n d = CerealDeserializer (S.isolate n (cerealDeserializer d))
  {-# INLINE isolate #-}

-- | Deserialize an unsigned 16-bit integer in host byte order.
word16H ∷ Deserializer μ ⇒ μ Word16
#ifdef WORDS_BIGENDIAN
word16H = word16B
#else
word16H = word16L
#endif
{-# INLINE word16H #-}

-- | Deserialize an unsigned 32-bit integer in host byte order.
word32H ∷ Deserializer μ ⇒ μ Word32
#ifdef WORDS_BIGENDIAN
word32H = word32B
#else
word32H = word32L
#endif
{-# INLINE word32H #-}

-- | Deserialize an unsigned 64-bit integer in host byte order.
word64H ∷ Deserializer μ ⇒ μ Word64
#ifdef WORDS_BIGENDIAN
word64H = word64B
#else
word64H = word64L
#endif
{-# INLINE word64H #-}

-- | Deserialize an unsigned native-sized integer in serializer default
--   byte order.
word ∷ Deserializer μ ⇒ μ Word
#if WORD_SIZE_IN_BITS == 32
word = fromIntegral <$> word32
#else
word = fromIntegral <$> word64
#endif
{-# INLINE word #-}

-- | Deserialize an unsigned native-sized integer in little endian.
wordL ∷ Deserializer μ ⇒ μ Word
#if WORD_SIZE_IN_BITS == 32
wordL = fromIntegral <$> word32L
#else
wordL = fromIntegral <$> word64L
#endif
{-# INLINE wordL #-}

-- | Deserialize an unsigned native-sized integer in big endian.
wordB ∷ Deserializer μ ⇒ μ Word
#if WORD_SIZE_IN_BITS == 32
wordB = fromIntegral <$> word32B
#else
wordB = fromIntegral <$> word64B
#endif
{-# INLINE wordB #-}

-- | Deserialize an unsigned native-sized integer in host byte order.
wordH ∷ Deserializer μ ⇒ μ Word
#ifdef WORDS_BIGENDIAN
wordH = wordB
#else
wordH = wordL
#endif
{-# INLINE wordH #-}

-- | Deserialize a signed 8-bit integer.
int8 ∷ Deserializer μ ⇒ μ Int8
int8 = fromIntegral <$> word8
{-# INLINE int8 #-}

-- | Deserialize a signed 16-bit integer in serializer default byte order.
int16 ∷ Deserializer μ ⇒ μ Int16
int16 = fromIntegral <$> word16
{-# INLINE int16 #-}

-- | Deserialize a signed 16-bit integer in little endian.
int16L ∷ Deserializer μ ⇒ μ Int16
int16L = fromIntegral <$> word16L
{-# INLINE int16L #-}

-- | Deserialize a signed 16-bit integer in big endian.
int16B ∷ Deserializer μ ⇒ μ Int16
int16B = fromIntegral <$> word16B
{-# INLINE int16B #-}

-- | Deserialize a signed 16-bit integer in host byte order.
int16H ∷ Deserializer μ ⇒ μ Int16
int16H = fromIntegral <$> word16H
{-# INLINE int16H #-}

-- | Deserialize a signed 32-bit integer in serializer default byte order.
int32 ∷ Deserializer μ ⇒ μ Int32
int32 = fromIntegral <$> word32
{-# INLINE int32 #-}

-- | Deserialize a signed 32-bit integer in little endian.
int32L ∷ Deserializer μ ⇒ μ Int32
int32L = fromIntegral <$> word32L
{-# INLINE int32L #-}

-- | Deserialize a signed 32-bit integer in big endian.
int32B ∷ Deserializer μ ⇒ μ Int32
int32B = fromIntegral <$> word32B
{-# INLINE int32B #-}

-- | Deserialize a signed 32-bit integer in host byte order.
int32H ∷ Deserializer μ ⇒ μ Int32
int32H = fromIntegral <$> word32H
{-# INLINE int32H #-}

-- | Deserialize a signed 64-bit integer in serializer default byte order.
int64 ∷ Deserializer μ ⇒ μ Int64
int64 = fromIntegral <$> word64
{-# INLINE int64 #-}

-- | Deserialize a signed 64-bit integer in little endian.
int64L ∷ Deserializer μ ⇒ μ Int64
int64L = fromIntegral <$> word64L
{-# INLINE int64L #-}

-- | Deserialize a signed 64-bit integer in big endian.
int64B ∷ Deserializer μ ⇒ μ Int64
int64B = fromIntegral <$> word64B
{-# INLINE int64B #-}

-- | Deserialize a signed 64-bit integer in host byte order.
int64H ∷ Deserializer μ ⇒ μ Int64
int64H = fromIntegral <$> word64H
{-# INLINE int64H #-}

-- | Deserialize a signed native-sized integer in serializer default byte
--   order.
int ∷ Deserializer μ ⇒ μ Int
#if WORD_SIZE_IN_BITS == 32
int = fromIntegral <$> int32
#else
int = fromIntegral <$> int64
#endif
{-# INLINE int #-}

-- | Deserialize a signed native-sized integer in little endian.
intL ∷ Deserializer μ ⇒ μ Int
#if WORD_SIZE_IN_BITS == 32
intL = fromIntegral <$> int32L
#else
intL = fromIntegral <$> int64L
#endif
{-# INLINE intL #-}

-- | Deserialize a signed native-sized integer in big endian.
intB ∷ Deserializer μ ⇒ μ Int
#if WORD_SIZE_IN_BITS == 32
intB = fromIntegral <$> int32B
#else
intB = fromIntegral <$> int64B
#endif
{-# INLINE intB #-}

-- | Deserialize a signed native-sized integer in host byte order.
intH ∷ Deserializer μ ⇒ μ Int
#if WORD_SIZE_IN_BITS == 32
intH = fromIntegral <$> int32H
#else
intH = fromIntegral <$> int64H
#endif
{-# INLINE intH #-}

-- | A shorthand for 'flip' ('<?>').
label ∷ Parsing μ ⇒ String → μ α → μ α
label = flip (<?>)
{-# INLINE label #-}

-- | Deserializer wrapper with little endian default byte order.
newtype LittleEndianDeserializer μ α =
          LittleEndianDeserializer { deserializeL ∷ μ α }
          deriving (Typeable, Data, Generic, Functor, Applicative,
                    Alternative, Monad, Parsing, LookAheadParsing)

instance Deserializer μ ⇒ Deserializer (LittleEndianDeserializer μ) where
  endian _ = LittleEndian
  {-# INLINE endian #-}
  word8 = LittleEndianDeserializer word8
  {-# INLINE word8 #-}
  word16 = LittleEndianDeserializer word16L
  {-# INLINE word16 #-}
  word32 = LittleEndianDeserializer word32L
  {-# INLINE word32 #-}
  word64 = LittleEndianDeserializer word64L
  {-# INLINE word64 #-}
  word16L = LittleEndianDeserializer word16L
  {-# INLINE word16L #-}
  word16B = LittleEndianDeserializer word16B
  {-# INLINE word16B #-}
  word32L = LittleEndianDeserializer word32L
  {-# INLINE word32L #-}
  word32B = LittleEndianDeserializer word32B
  {-# INLINE word32B #-}
  word64L = LittleEndianDeserializer word64L
  {-# INLINE word64L #-}
  word64B = LittleEndianDeserializer word64B
  {-# INLINE word64B #-}
  satisfy = LittleEndianDeserializer . satisfy
  {-# INLINE satisfy #-}
  byte = LittleEndianDeserializer . byte
  {-# INLINE byte #-}
  notByte = LittleEndianDeserializer . notByte
  {-# INLINE notByte #-}
  bytes = LittleEndianDeserializer . bytes
  {-# INLINE bytes #-}
  skip = LittleEndianDeserializer . skip
  {-# INLINE skip #-}
  ensure = LittleEndianDeserializer . ensure
  {-# INLINE ensure #-}
  ensure_ = LittleEndianDeserializer . ensure_
  {-# INLINE ensure_ #-}
  take = LittleEndianDeserializer . take
  {-# INLINE take #-}
  chunk = LittleEndianDeserializer chunk
  {-# INLINE chunk #-}
  isolate n = LittleEndianDeserializer . isolate n . deserializeL
  {-# INLINE isolate #-}

-- | Deserializer wrapper with big endian default byte order.
newtype BigEndianDeserializer μ α =
          BigEndianDeserializer { deserializeB ∷ μ α }
          deriving (Typeable, Data, Generic, Functor, Applicative,
                    Alternative, Monad, Parsing, LookAheadParsing)

instance Deserializer μ ⇒ Deserializer (BigEndianDeserializer μ) where
  endian _ = BigEndian
  {-# INLINE endian #-}
  word8 = BigEndianDeserializer word8
  {-# INLINE word8 #-}
  word16 = BigEndianDeserializer word16B
  {-# INLINE word16 #-}
  word32 = BigEndianDeserializer word32B
  {-# INLINE word32 #-}
  word64 = BigEndianDeserializer word64B
  {-# INLINE word64 #-}
  word16L = BigEndianDeserializer word16L
  {-# INLINE word16L #-}
  word16B = BigEndianDeserializer word16B
  {-# INLINE word16B #-}
  word32L = BigEndianDeserializer word32L
  {-# INLINE word32L #-}
  word32B = BigEndianDeserializer word32B
  {-# INLINE word32B #-}
  word64L = BigEndianDeserializer word64L
  {-# INLINE word64L #-}
  word64B = BigEndianDeserializer word64B
  {-# INLINE word64B #-}
  satisfy = BigEndianDeserializer . satisfy
  {-# INLINE satisfy #-}
  byte = BigEndianDeserializer . byte
  {-# INLINE byte #-}
  notByte = BigEndianDeserializer . notByte
  {-# INLINE notByte #-}
  bytes = BigEndianDeserializer . bytes
  {-# INLINE bytes #-}
  skip = BigEndianDeserializer . skip
  {-# INLINE skip #-}
  ensure = BigEndianDeserializer . ensure
  {-# INLINE ensure #-}
  ensure_ = BigEndianDeserializer . ensure_
  {-# INLINE ensure_ #-}
  take = BigEndianDeserializer . take
  {-# INLINE take #-}
  chunk = BigEndianDeserializer chunk
  {-# INLINE chunk #-}
  isolate n = BigEndianDeserializer . isolate n . deserializeB
  {-# INLINE isolate #-}

-- | Force the default byte order.
deserializeIn ∷ Deserializer μ
              ⇒ Endian → (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α
deserializeIn LittleEndian = deserializeL
deserializeIn BigEndian    = deserializeB
{-# INLINE deserializeIn #-}

-- | Force the default byte order to be the host byte order.
deserializeH ∷ Deserializer μ ⇒ (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α
#ifdef WORDS_BIGENDIAN
deserializeH = deserializeB
#else
deserializeH = deserializeL
#endif

-- | Deserialization result.
data Deserialized α = Deserialized α
                    | Malformed [String] String

-- | Map 'Deserialized' to 'True' and 'Malformed' to 'False'.
isDeserialized ∷ Deserialized α → Bool
isDeserialized (Deserialized _) = True
isDeserialized (Malformed _ _)  = False

-- | Map 'Deserialized' to 'False' and 'Malformed' to 'True'.
isMalformed ∷ Deserialized α → Bool
isMalformed (Deserialized _) = False
isMalformed (Malformed _ _)  = True

-- | Map 'Deserialized' values to 'Just' and 'Malformed' to 'Nothing'.
maybeDeserialized ∷ Deserialized α → Maybe α
maybeDeserialized (Deserialized a) = Just a
maybeDeserialized (Malformed _ _)  = Nothing

-- | Deserialize a 'LBS.ByteString' via the default deserializer.
defaultDeserializer ∷ (∀ μ . Deserializer μ ⇒ μ α) → LBS.ByteString
                    → Deserialized α
defaultDeserializer m i = case B.runGetOrFail (binaryDeserializer m) i of
  Left (_, _, e) → case splitOn "\n" e of
    []  → Malformed [] e
    [_] → Malformed [] e
    es  → Malformed (init es) (last es)
  Right (_, _, a) →
    Deserialized a

-- | Deserializable type. 'get' must not rely on 'eof'.
class Deserializable α where
  get ∷ Deserializer μ ⇒ μ α

instance Deserializable Bool where
  get = do w ← word8
           case w of
             0 → return False
             1 → return True
             _ → unexpected (show w)

instance Deserializable Word8 where
  get = word8
  {-# INLINE get #-}

instance Deserializable Word16 where
  get = word16
  {-# INLINE get #-}

instance Deserializable Word32 where
  get = word32
  {-# INLINE get #-}

instance Deserializable Word64 where
  get = word64
  {-# INLINE get #-}

instance Deserializable Word where
  get = word
  {-# INLINE get #-}

instance Deserializable Int8 where
  get = int8
  {-# INLINE get #-}

instance Deserializable Int16 where
  get = int16
  {-# INLINE get #-}

instance Deserializable Int32 where
  get = int32
  {-# INLINE get #-}

instance Deserializable Int64 where
  get = int64
  {-# INLINE get #-}

instance Deserializable Int where
  get = int
  {-# INLINE get #-}

instance (Deserializable α, Deserializable β) ⇒ Deserializable (α, β) where
  get = (,) <$> get <*> get
  {-# INLINE get #-}

instance Deserializable α ⇒ Deserializable (Maybe α) where
  get = do w ← word8
           case w of
             0 → return Nothing
             1 → Just <$> get
             _ → unexpected (show w)

instance (Deserializable α, Deserializable β)
         ⇒ Deserializable (Either α β) where
  get = do w ← word8
           case w of
             0 → Left <$> get
             1 → Right <$> get
             _ → unexpected (show w)

instance Deserializable BS.ByteString where
  get = do l ← int <?> "length"
           unless (l >= 0) $ unexpected "negative length"
           take l <?> "contents"
  {-# INLINABLE get #-}

instance Deserializable SBS.ShortByteString where
  get = SBS.toShort <$> get
  {-# INLINE get #-}

-- | Deserialize a value using the provided default byte order.
getIn ∷ (Deserializer μ, Deserializable α) ⇒ Endian → μ α
getIn e = deserializeIn e get
{-# INLINE getIn #-}

-- | Deserialize a value using little endian as the default byte order.
getL ∷ (Deserializer μ, Deserializable α) ⇒ μ α
getL = deserializeL get
{-# INLINE getL #-}

-- | Deserialize a value using big endian as the default byte order.
getB ∷ (Deserializer μ, Deserializable α) ⇒ μ α
getB = deserializeB get
{-# INLINE getB #-}

-- | Deserialize a value using host byte order as the default byte order.
getH ∷ (Deserializer μ, Deserializable α) ⇒ μ α
#ifdef WORDS_BIGENDIAN
getH = getB
#else
getH = getL
#endif
{-# INLINE getH #-}

-- | Deserialize a value of type @α@ from a list of bytes via
-- the 'defaultDeserializer'.
deserializeBytes ∷ Deserializable α ⇒ [Word8] → Deserialized α
deserializeBytes = defaultDeserializer get . LBS.pack
{-# INLINE deserializeBytes #-}

-- | Provide a hint for the type system when using 'deserializeBytes'.
deserializeBytesAs ∷ Deserializable α ⇒ p α → [Word8] → Deserialized α
deserializeBytesAs _ = deserializeBytes
{-# INLINE deserializeBytesAs #-}

-- | Deserialize a value of type @α@ from a 'BS.ByteString' via
-- the 'defaultDeserializer'.
deserializeByteString ∷ Deserializable α
                      ⇒ BS.ByteString → Deserialized α
deserializeByteString = defaultDeserializer get . LBS.fromStrict
{-# INLINE deserializeByteString #-}

-- | Provide a hint for the type system when using 'deserializeByteString'.
deserializeByteStringAs ∷ Deserializable α
                        ⇒ p α → BS.ByteString → Deserialized α
deserializeByteStringAs _ = deserializeByteString
{-# INLINE deserializeByteStringAs #-}

-- | Deserialize a value of type @α@ from a 'LBS.ByteString' via
-- the 'defaultDeserializer'.
deserializeLazyByteString ∷ Deserializable α
                          ⇒ LBS.ByteString → Deserialized α
deserializeLazyByteString = defaultDeserializer get
{-# INLINE deserializeLazyByteString #-}

-- | Provide a hint for the type system when using
-- 'deserializeLazyByteString'.
deserializeLazyByteStringAs ∷ Deserializable α
                            ⇒ p α → LBS.ByteString → Deserialized α
deserializeLazyByteStringAs _ = deserializeLazyByteString
{-# INLINE deserializeLazyByteStringAs #-}

-- | A shorthand for @'maybeDeserialized' . 'deserializeBytes'@.
fromBytes ∷ Deserializable α ⇒ [Word8] → Maybe α
fromBytes = maybeDeserialized . deserializeBytes
{-# INLINE fromBytes #-}

-- | Provide a hint for the type system when using 'fromBytes'
fromBytesAs ∷ Deserializable α ⇒ p α → [Word8] → Maybe α
fromBytesAs _ = fromBytes
{-# INLINE fromBytesAs #-}

-- | A shorthand for @'maybeDeserialized' . 'deserializeByteString'@.
fromByteString ∷ Deserializable α ⇒ BS.ByteString → Maybe α
fromByteString = maybeDeserialized . deserializeByteString
{-# INLINE fromByteString #-}

-- | Provide a hint for the type system when using 'fromByteString'
fromByteStringAs ∷ Deserializable α ⇒ p α → BS.ByteString → Maybe α
fromByteStringAs _ = fromByteString
{-# INLINE fromByteStringAs #-}

-- | A shorthand for @'maybeDeserialized' . 'deserializeLazyByteString'@.
fromLazyByteString ∷ Deserializable α ⇒ LBS.ByteString → Maybe α
fromLazyByteString = maybeDeserialized . deserializeLazyByteString
{-# INLINE fromLazyByteString #-}

-- | Provide a hint for the type system when using 'fromLazyByteString'
fromLazyByteStringAs ∷ Deserializable α ⇒ p α → LBS.ByteString → Maybe α
fromLazyByteStringAs _ = fromLazyByteString
{-# INLINE fromLazyByteStringAs #-}

-- | Deserializable type. 'getRest' must consume all the remaining input
--   or fail.
class RestDeserializable α where
  getRest ∷ Deserializer μ ⇒ μ α

instance RestDeserializable BS.ByteString where
  getRest = go []
    where go acc = do bs ← chunk
                      if BS.null bs then return $ BS.concat $ reverse acc
                                    else go (bs : acc)

instance RestDeserializable SBS.ShortByteString where
  getRest = SBS.toShort <$> getRest
  {-# INLINE getRest #-}

instance RestDeserializable LBS.ByteString where
  getRest = go []
    where go acc = do bs ← chunk
                      if BS.null bs then return $ LBS.fromChunks $ reverse acc
                                    else go (bs : acc)

instance RestDeserializable BB.Builder where
  getRest = BB.lazyByteString <$> getRest
  {-# INLINE getRest #-}

instance (RestDeserializable α, RestDeserializable β)
         ⇒ RestDeserializable (Either α β) where
  getRest = word8 >>= \case
              0 → Left <$> getRest
              1 → Right <$> getRest
              w → unexpected (show w)
  {-# INLINABLE getRest #-}

instance (Deserializable α, RestDeserializable β)
         ⇒ RestDeserializable (α, β) where
  getRest = (,) <$> get <*> getRest
  {-# INLINE getRest #-}

instance Deserializable α ⇒ RestDeserializable [α] where
  getRest = ([] <$ eof) <|> ((:) <$> get <*> getRest)