{-# OPTIONS_HADDOCK not-home #-}

-- | Public API for serialisation of keys, blobs and values
--
module Database.LSMTree.Internal.Serialise.Class (
    -- * SerialiseKey
    SerialiseKey (..)
  , serialiseKeyIdentity
  , serialiseKeyIdentityUpToSlicing
  , SerialiseKeyOrderPreserving
  , serialiseKeyPreservesOrdering
    -- * SerialiseValue
  , SerialiseValue (..)
  , serialiseValueIdentity
  , serialiseValueIdentityUpToSlicing
    -- * RawBytes
  , RawBytes (..)
  , packSlice
    -- * Errors
  , requireBytesExactly
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short.Internal as SBS
import qualified Data.ByteString.UTF8 as UTF8
import           Data.Int (Int16, Int32, Int64, Int8)
import           Data.Monoid (Sum (..))
import qualified Data.Primitive as P
import qualified Data.Vector.Primitive as VP
import           Data.Void (Void, absurd)
import           Data.Word (Word16, Word32, Word64, Word8)
import           Database.LSMTree.Internal.ByteString (byteArrayToSBS)
import           Database.LSMTree.Internal.Primitive
import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
import qualified Database.LSMTree.Internal.RawBytes as RB
import           Database.LSMTree.Internal.Vector
import           Numeric (showInt)

{-------------------------------------------------------------------------------
  SerialiseKey
-------------------------------------------------------------------------------}

{- | Serialisation of keys.

Instances should satisfy the following laws:

[Identity]
  @'deserialiseKey' ('serialiseKey' x) == x@
[Identity up to slicing]
  @'deserialiseKey' ('packSlice' prefix ('serialiseKey' x) suffix) == x@
-}
class SerialiseKey k where
  serialiseKey :: k -> RawBytes
  -- TODO: 'deserialiseKey' is only strictly necessary for range queries.
  -- It might make sense to move it to a separate class, which could also
  -- require total deserialisation (potentially using 'Either').
  deserialiseKey :: RawBytes -> k

-- | Test the __Identity__ law for the 'SerialiseKey' class
serialiseKeyIdentity :: (Eq k, SerialiseKey k) => k -> Bool
serialiseKeyIdentity x = deserialiseKey (serialiseKey x) == x

-- | Test the __Identity up to slicing__ law for the 'SerialiseKey' class
serialiseKeyIdentityUpToSlicing ::
     (Eq k, SerialiseKey k)
  => RawBytes -> k -> RawBytes -> Bool
serialiseKeyIdentityUpToSlicing prefix x suffix =
    deserialiseKey (packSlice prefix (serialiseKey x) suffix) == x

{- |
Order-preserving serialisation of keys.

Table data is sorted by /serialised/ keys.
Range lookups and cursors return entries in this order.
If serialisation does not preserve the ordering of /unserialised/ keys,
then range lookups and cursors return entries out of order.

If the 'SerialiseKey' instance for a type preserves the ordering,
then it can safely be given an instance of 'SerialiseKeyOrderPreserving'.
These should satisfy the following law:

[Order-preserving]
  @x \`'compare'\` y == 'serialiseKey' x \`'compare'\` 'serialiseKey' y@

Serialised keys are lexicographically ordered.
To satisfy the __Order-preserving__ law, keys should be serialised into a big-endian format.
-}
class SerialiseKey k => SerialiseKeyOrderPreserving k where

-- | Test the __Order-preserving__ law for the 'SerialiseKeyOrderPreserving' class
serialiseKeyPreservesOrdering :: (Ord k, SerialiseKey k) => k -> k -> Bool
serialiseKeyPreservesOrdering x y = x `compare` y == serialiseKey x `compare` serialiseKey y

{-------------------------------------------------------------------------------
  SerialiseValue
-------------------------------------------------------------------------------}

{- | Serialisation of values and blobs.

Instances should satisfy the following laws:

[Identity]
  @'deserialiseValue' ('serialiseValue' x) == x@

[Identity up to slicing]
  @'deserialiseValue' ('packSlice' prefix ('serialiseValue' x) suffix) == x@
-}
class SerialiseValue v where
  serialiseValue :: v -> RawBytes
  deserialiseValue :: RawBytes -> v

-- | Test the __Identity__ law for the 'SerialiseValue' class
serialiseValueIdentity :: (Eq v, SerialiseValue v) => v -> Bool
serialiseValueIdentity x = deserialiseValue (serialiseValue x) == x

-- | Test the __Identity up to slicing__ law for the 'SerialiseValue' class
serialiseValueIdentityUpToSlicing ::
     (Eq v, SerialiseValue v)
  => RawBytes -> v -> RawBytes -> Bool
serialiseValueIdentityUpToSlicing prefix x suffix =
    deserialiseValue (packSlice prefix (serialiseValue x) suffix) == x

{-------------------------------------------------------------------------------
  RawBytes
-------------------------------------------------------------------------------}

-- | @'packSlice' prefix x suffix@ makes @x@ into a slice with @prefix@ bytes on
-- the left and @suffix@ bytes on the right.
packSlice :: RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice prefix x suffix =
    RB.take (RB.size x) (RB.drop (RB.size prefix) (prefix <> x <> suffix))

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

-- | @'requireBytesExactly' tyName expected actual x@
requireBytesExactly :: String -> Int -> Int -> a -> a
requireBytesExactly tyName expected actual x
  | expected == actual = x
  | otherwise          =
        error
      $ showString "deserialise "
      . showString tyName
      . showString ": expected "
      . showInt expected
      . showString " bytes, but got "
      . showInt actual
      $ ""

{-------------------------------------------------------------------------------
  Int
-------------------------------------------------------------------------------}

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Int8 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int8" 1 len $ indexInt8Array ba off

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Int8 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int8" 1 len $ indexInt8Array ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Int16 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapInt16 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int16" 2 len $ byteSwapInt16 (indexWord8ArrayAsInt16 ba off)

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Int16 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int16" 2 len $ indexWord8ArrayAsInt16 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Int32 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapInt32 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int32" 4 len $ byteSwapInt32 (indexWord8ArrayAsInt32 ba off)

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Int32 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int32" 4 len $ indexWord8ArrayAsInt32 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Int64 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapInt64 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int64" 8 len $ byteSwapInt64 (indexWord8ArrayAsInt64 ba off)

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Int64 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int64" 8 len $ indexWord8ArrayAsInt64 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Int where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapInt x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int" 8 len $ byteSwapInt (indexWord8ArrayAsInt ba off)

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Int where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Int" 8 len $ indexWord8ArrayAsInt ba off

{-------------------------------------------------------------------------------
  Word
-------------------------------------------------------------------------------}

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Word8 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim  x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word8" 1 len  (indexWord8Array ba off)

instance SerialiseKeyOrderPreserving Word8

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Word8 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word8" 1 len $ indexWord8Array ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Word16 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapWord16 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word16" 2 len $ byteSwapWord16 (indexWord8ArrayAsWord16 ba off)

instance SerialiseKeyOrderPreserving Word16

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Word16 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word16" 2 len $ indexWord8ArrayAsWord16 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Word32 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapWord32 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word32" 4 len $ byteSwapWord32 (indexWord8ArrayAsWord32 ba off)

instance SerialiseKeyOrderPreserving Word32

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Word32 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word32" 4 len $ indexWord8ArrayAsWord32 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Word64 where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapWord64 x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word64" 8 len $ byteSwapWord64 (indexWord8ArrayAsWord64 ba off)

instance SerialiseKeyOrderPreserving Word64

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Word64 where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word64" 8 len $ indexWord8ArrayAsWord64 ba off

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(1)\).
-}
instance SerialiseKey Word where
  serialiseKey x = RB.RawBytes $ byteVectorFromPrim $ byteSwapWord x

  deserialiseKey (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word" 8 len $ byteSwapWord (indexWord8ArrayAsWord ba off)

instance SerialiseKeyOrderPreserving Word

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(1)\).
-}
instance SerialiseValue Word where
  serialiseValue x = RB.RawBytes $ byteVectorFromPrim $ x

  deserialiseValue (RawBytes (VP.Vector off len ba)) =
    requireBytesExactly "Word" 8 len $ indexWord8ArrayAsWord ba off

{-------------------------------------------------------------------------------
  String
-------------------------------------------------------------------------------}

{- |
@'serialiseKey'@: \(O(n)\).

@'deserialiseKey'@: \(O(n)\).

The 'String' is (de)serialised as UTF-8.
-}
instance SerialiseKey String where
  -- TODO: Optimise. The performance is \(O(n) + O(n)\) but it could be \(O(n)\).
  serialiseKey = serialiseKey . UTF8.fromString
  deserialiseKey = UTF8.toString . deserialiseKey

instance SerialiseKeyOrderPreserving String

{- |
@'serialiseKey'@: \(O(n)\).

@'deserialiseKey'@: \(O(n)\).

The 'String' is (de)serialised as UTF-8.
-}
instance SerialiseValue String where
  -- TODO: Optimise. The performance is \(O(n) + O(n)\) but it could be \(O(n)\).
  serialiseValue = serialiseValue . UTF8.fromString
  deserialiseValue = UTF8.toString . deserialiseValue

{-------------------------------------------------------------------------------
  ByteString
-------------------------------------------------------------------------------}

{- |
@'serialiseKey'@: \(O(n)\).

@'deserialiseKey'@: \(O(n)\).
-}
instance SerialiseKey LBS.ByteString where
  -- TODO: Optimise. The performance is \(O(n) + O(n)\) but it could be \(O(n)\).
  serialiseKey = serialiseKey . LBS.toStrict
  deserialiseKey = B.toLazyByteString . RB.builder

instance SerialiseKeyOrderPreserving LBS.ByteString

{- |
@'serialiseValue'@: \(O(n)\).

@'deserialiseValue'@: \(O(n)\).
-}
instance SerialiseValue LBS.ByteString where
  -- TODO: Optimise. The performance is \(O(n) + O(n)\) but it could be \(O(n)\).
  serialiseValue = serialiseValue . LBS.toStrict
  deserialiseValue = B.toLazyByteString . RB.builder

{- |
@'serialiseKey'@: \(O(n)\).

@'deserialiseKey'@: \(O(n)\).
-}
instance SerialiseKey BS.ByteString where
  serialiseKey = serialiseKey . SBS.toShort
  deserialiseKey = SBS.fromShort . deserialiseKey

instance SerialiseKeyOrderPreserving BS.ByteString

{- |
@'serialiseValue'@: \(O(n)\).

@'deserialiseValue'@: \(O(n)\).
-}
instance SerialiseValue BS.ByteString where
  serialiseValue = serialiseValue . SBS.toShort
  deserialiseValue = SBS.fromShort . deserialiseValue

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(n)\).
-}
instance SerialiseKey SBS.ShortByteString where
  serialiseKey = RB.fromShortByteString
  deserialiseKey = byteArrayToSBS . RB.force

instance SerialiseKeyOrderPreserving SBS.ShortByteString

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(n)\).
-}
instance SerialiseValue SBS.ShortByteString where
  serialiseValue = RB.fromShortByteString
  deserialiseValue = byteArrayToSBS . RB.force

{-------------------------------------------------------------------------------
  ByteArray
-------------------------------------------------------------------------------}

{- |
@'serialiseKey'@: \(O(1)\).

@'deserialiseKey'@: \(O(n)\).
-}
instance SerialiseKey P.ByteArray where
  serialiseKey ba = RB.fromByteArray 0 (P.sizeofByteArray ba) ba
  deserialiseKey = RB.force

{- |
@'serialiseValue'@: \(O(1)\).

@'deserialiseValue'@: \(O(n)\).
-}
instance SerialiseValue P.ByteArray where
  serialiseValue ba = RB.fromByteArray 0 (P.sizeofByteArray ba) ba
  deserialiseValue = RB.force

{-------------------------------------------------------------------------------
  Void
-------------------------------------------------------------------------------}

-- | The implementation of 'deserialiseKey' throws an exception.
instance SerialiseKey Void where
  serialiseKey = absurd
  deserialiseKey = error "deserialiseKey: cannot deserialise into Void"


-- | The implementation of 'deserialiseValue' throws an exception.
instance SerialiseValue Void where
  serialiseValue = absurd
  deserialiseValue = error "deserialiseValue: cannot deserialise into Void"

{-------------------------------------------------------------------------------
  Sum
-------------------------------------------------------------------------------}

{- |
An instance for 'Sum' which is transparent to the serialisation of the value type.

__NOTE:__ If you want to serialise @'Sum' a@ differently from @a@, you must use another newtype wrapper.
-}
instance SerialiseValue a => SerialiseValue (Sum a) where
  serialiseValue (Sum v) = serialiseValue v

  deserialiseValue = Sum . deserialiseValue