{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

-- |
-- Module      :  Codec.Scale.Core
-- Copyright   :  Aleksandr Krupenkin 2016-2021
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  unportable
--
-- Particular core type instances.
--

module Codec.Scale.Core (Compact(..)) where

import           Control.Monad       (replicateM)
import           Data.Bit            (Bit, castFromWords8, cloneToWords8)
import           Data.ByteString     (ByteString)
import qualified Data.ByteString     as BS (length)
import           Data.Int            (Int16, Int32, Int64, Int8)
import           Data.Serialize.Get  (getByteString, getInt16le, getInt32le,
                                      getInt64le, getInt8, getWord16le,
                                      getWord32le, getWord64le, getWord8)
import           Data.Serialize.Put  (putByteString, putInt16le, putInt32le,
                                      putInt64le, putInt8, putWord16le,
                                      putWord32le, putWord64le, putWord8)
import           Data.Text           (Text)
import           Data.Text.Encoding  (decodeUtf8', encodeUtf8)
import           Data.Vector.Unboxed (Unbox, Vector)
import qualified Data.Vector.Unboxed as V
import           Data.Word           (Word16, Word32, Word64, Word8)
import           Generics.SOP        ()

import           Codec.Scale.Class   (Decode (..), Encode (..))
import           Codec.Scale.Compact (Compact (..))
import           Codec.Scale.Generic ()
import           Codec.Scale.TH      (tupleInstances)

--
-- Empty instance.
--

instance Encode () where
    put :: Putter ()
put = Putter ()
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Decode () where
    get :: Get ()
get = () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

--
-- Boolean instance.
--

instance Encode Bool where
    put :: Putter Bool
put Bool
False = Putter Word8
putWord8 Word8
0
    put Bool
True  = Putter Word8
putWord8 Word8
1

instance Decode Bool where
    get :: Get Bool
get = do Word8
x <- Get Word8
getWord8
             case Word8
x of
               Word8
0 -> Bool -> Get Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Word8
1 -> Bool -> Get Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               Word8
_ -> String -> Get Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid boolean representation"

--
-- Integer instances.
--

instance Encode Word8 where
    put :: Putter Word8
put = Putter Word8
putWord8

instance Decode Word8 where
    get :: Get Word8
get = Get Word8
getWord8

instance Encode Word16 where
    put :: Putter Word16
put = Putter Word16
putWord16le

instance Decode Word16 where
    get :: Get Word16
get = Get Word16
getWord16le

instance Encode Word32 where
    put :: Putter Word32
put = Putter Word32
putWord32le

instance Decode Word32 where
    get :: Get Word32
get = Get Word32
getWord32le

instance Encode Word64 where
    put :: Putter Word64
put = Putter Word64
putWord64le

instance Decode Word64 where
    get :: Get Word64
get = Get Word64
getWord64le

instance Encode Int8 where
    put :: Putter Int8
put = Putter Int8
putInt8

instance Decode Int8 where
    get :: Get Int8
get = Get Int8
getInt8

instance Encode Int16 where
    put :: Putter Int16
put = Putter Int16
putInt16le

instance Decode Int16 where
    get :: Get Int16
get = Get Int16
getInt16le

instance Encode Int32 where
    put :: Putter Int32
put = Putter Int32
putInt32le

instance Decode Int32 where
    get :: Get Int32
get = Get Int32
getInt32le

instance Encode Int64 where
    put :: Putter Int64
put = Putter Int64
putInt64le

instance Decode Int64 where
    get :: Get Int64
get = Get Int64
getInt64le

--
-- Option type instances.
--

-- Let's map `Maybe a` type to Rust `Option<T>`: Just -> Some, Nothing -> None

instance Encode a => Encode (Maybe a) where
    put :: Putter (Maybe a)
put (Just a
a) = Putter Word8
putWord8 Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter a
forall a. Encode a => Putter a
put a
a
    put Maybe a
Nothing  = Putter Word8
putWord8 Word8
0

instance Decode a => Decode (Maybe a) where
    get :: Get (Maybe a)
get = do
        Word8
x <- Get Word8
getWord8
        case Word8
x of
          Word8
0 -> Maybe a -> Get (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
          Word8
1 -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Get a -> Get (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall a. Decode a => Get a
get
          Word8
_ -> String -> Get (Maybe a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpecded first byte decoding Option"

-- Option<bool> is exception and it is always one byte

instance {-# OVERLAPPING #-} Encode (Maybe Bool) where
    put :: Putter (Maybe Bool)
put Maybe Bool
Nothing      = Putter Word8
putWord8 Word8
0
    put (Just Bool
False) = Putter Word8
putWord8 Word8
1
    put (Just Bool
True)  = Putter Word8
putWord8 Word8
2

instance {-# OVERLAPPING #-} Decode (Maybe Bool) where
    get :: Get (Maybe Bool)
get = do
        Word8
x <- Get Word8
getWord8
        case Word8
x of
          Word8
0 -> Maybe Bool -> Get (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
          Word8
1 -> Maybe Bool -> Get (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
          Word8
2 -> Maybe Bool -> Get (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
          Word8
_ -> String -> Get (Maybe Bool)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpecded first byte decoding OptionBool"

--
-- Result type isntances.
--

-- Let's map `Ether a b` type to Rust `Result<T, E>`: Left -> Error, Right -> Ok

instance (Encode a, Encode b) => Encode (Either a b) where
    put :: Putter (Either a b)
put (Right b
a) = Putter Word8
putWord8 Word8
0 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
forall a. Encode a => Putter a
put b
a
    put (Left a
a)  = Putter Word8
putWord8 Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter a
forall a. Encode a => Putter a
put a
a

instance (Decode a, Decode b) => Decode (Either a b) where
    get :: Get (Either a b)
get = do
        Word8
x <- Get Word8
getWord8
        case Word8
x of
          Word8
0 -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Get b -> Get (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get b
forall a. Decode a => Get a
get
          Word8
1 -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Get a -> Get (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall a. Decode a => Get a
get
          Word8
_ -> String -> Get (Either a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected first byte decoding Result"


--
-- Tuple type instances.
--

$(concat <$> mapM tupleInstances [2..20])

--
-- Vector type instances.
--

instance Encode a => Encode [a] where
    put :: Putter [a]
put [a]
list = do
        Putter (Compact Int)
forall a. Encode a => Putter a
put (Int -> Compact Int
forall a. a -> Compact a
Compact (Int -> Compact Int) -> Int -> Compact Int
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list)
        (a -> PutM ()) -> Putter [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> PutM ()
forall a. Encode a => Putter a
put [a]
list

instance Decode a => Decode [a] where
    get :: Get [a]
get = do
        Compact Int
len <- Get (Compact Int)
forall a. Decode a => Get a
get
        Int -> Get a -> Get [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Compact Int -> Int
forall a. Compact a -> a
unCompact Compact Int
len) Get a
forall a. Decode a => Get a
get

instance (Encode a, Unbox a) => Encode (Vector a) where
    put :: Putter (Vector a)
put Vector a
vec = do
        Putter (Compact Int)
forall a. Encode a => Putter a
put (Int -> Compact Int
forall a. a -> Compact a
Compact (Int -> Compact Int) -> Int -> Compact Int
forall a b. (a -> b) -> a -> b
$ Vector a -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector a
vec)
        (a -> PutM ()) -> Putter (Vector a)
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
(a -> m b) -> Vector a -> m ()
V.mapM_ a -> PutM ()
forall a. Encode a => Putter a
put Vector a
vec

instance (Decode a, Unbox a) => Decode (Vector a) where
    get :: Get (Vector a)
get = do
        Compact Int
len <- Get (Compact Int)
forall a. Decode a => Get a
get
        Int -> Get a -> Get (Vector a)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
V.replicateM (Compact Int -> Int
forall a. Compact a -> a
unCompact Compact Int
len) Get a
forall a. Decode a => Get a
get

instance {-# OVERLAPPING #-} Encode (Vector Bit) where
    put :: Putter (Vector Bit)
put Vector Bit
vec = do
        let encoded :: Vector Word8
encoded = Vector Bit -> Vector Word8
cloneToWords8 Vector Bit
vec
        Putter (Compact Int)
forall a. Encode a => Putter a
put (Int -> Compact Int
forall a. a -> Compact a
Compact (Int -> Compact Int) -> Int -> Compact Int
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector Word8
encoded)
        Putter Word8 -> Vector Word8 -> PutM ()
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
(a -> m b) -> Vector a -> m ()
V.mapM_ Putter Word8
forall a. Encode a => Putter a
put Vector Word8
encoded

instance {-# OVERLAPPING #-} Decode (Vector Bit) where
    get :: Get (Vector Bit)
get = do
        Compact Int
len <- Get (Compact Int)
forall a. Decode a => Get a
get
        Vector Word8 -> Vector Bit
castFromWords8 (Vector Word8 -> Vector Bit)
-> Get (Vector Word8) -> Get (Vector Bit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Word8 -> Get (Vector Word8)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
V.replicateM (Compact Int -> Int
forall a. Compact a -> a
unCompact Compact Int
len) Get Word8
forall a. Decode a => Get a
get

instance Encode ByteString where
    put :: Putter ByteString
put ByteString
bs = do
        Putter (Compact Int)
forall a. Encode a => Putter a
put (Int -> Compact Int
forall a. a -> Compact a
Compact (Int -> Compact Int) -> Int -> Compact Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs)
        Putter ByteString
putByteString ByteString
bs

instance Decode ByteString where
    get :: Get ByteString
get = do
        Compact Int
len <- Get (Compact Int)
forall a. Decode a => Get a
get
        Int -> Get ByteString
getByteString (Compact Int -> Int
forall a. Compact a -> a
unCompact Compact Int
len)

--
-- Text type instances.
--

instance Encode Text where
    put :: Putter Text
put Text
str = do
        let encoded :: ByteString
encoded = Text -> ByteString
encodeUtf8 Text
str
        Putter (Compact Int)
forall a. Encode a => Putter a
put (Int -> Compact Int
forall a. a -> Compact a
Compact (Int -> Compact Int) -> Int -> Compact Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
encoded)
        Putter ByteString
putByteString ByteString
encoded

instance Decode Text where
    get :: Get Text
get = do
        Compact Int
len <- Get (Compact Int)
forall a. Decode a => Get a
get
        ByteString
str <- Int -> Get ByteString
getByteString (Compact Int -> Int
forall a. Compact a -> a
unCompact Compact Int
len)
        (UnicodeException -> Get Text)
-> (Text -> Get Text) -> Either UnicodeException Text -> Get Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text)
-> (UnicodeException -> String) -> UnicodeException -> Get Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show) Text -> Get Text
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
str)