module Codec.Borsh.Decoding (
    -- * Decoders for non-composite types mandated by the Borsh spec
    decodeU8
  , decodeU16
  , decodeU32
  , decodeU64
  , decodeU128
  , decodeI8
  , decodeI16
  , decodeI32
  , decodeI64
  , decodeI128
  , decodeF32
  , decodeF64
  , decodeString
    -- * Decoders for composite types mandated by the Borsh spec
  , decodeArray
  , decodeVec
  , decodeOption
  , decodeHashSet
  , decodeHashMap
  , decodeStruct
  , decodeEnum
    -- * Decoders for Haskell types not mandated by the Borsh spec
  , decodeLazyByteString
  , decodeStrictByteString
  , decodeChar
  , decodeBool
  ) where

import Data.Char (chr)
import Data.Int
import Data.Map (Map)
import Data.Maybe
import Data.Proxy
import Data.Set (Set)
import Data.STRef
import Data.Text (Text)
import Data.WideWord.Word128
import Data.WideWord.Int128
import Data.Word
import Generics.SOP
import GHC.TypeLits

import qualified Data.ByteString             as S
import qualified Data.ByteString.Lazy        as L
import qualified Data.Map.Strict             as Map
import qualified Data.Set                    as Set
import qualified Data.Text.Encoding          as Text
import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Generic.Mutable as GM

import Codec.Borsh.Incremental
import Codec.Borsh.Incremental.Decoder (decodeLittleEndian)
import Codec.Borsh.Internal.Util.BitwiseCast
import Codec.Borsh.Internal.Util.SOP
import Data.FixedSizeArray (FixedSizeArray, MFixedSizeArray)

import qualified Data.FixedSizeArray as FSA

{-------------------------------------------------------------------------------
  Decoders for the non-composite types mandated by the Borsh spec
-------------------------------------------------------------------------------}

decodeU8   :: Decoder s Word8
decodeU16  :: Decoder s Word16
decodeU32  :: Decoder s Word32
decodeU64  :: Decoder s Word64
decodeU128 :: Decoder s Word128

decodeU8 :: forall s. Decoder s Word8
decodeU8   = forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeU16 :: forall s. Decoder s Word16
decodeU16  = forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeU32 :: forall s. Decoder s Word32
decodeU32  = forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeU64 :: forall s. Decoder s Word64
decodeU64  = forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeU128 :: forall s. Decoder s Word128
decodeU128 = forall s a. ByteSwap a => Decoder s a
decodeLittleEndian

decodeI8   :: Decoder s Int8
decodeI16  :: Decoder s Int16
decodeI32  :: Decoder s Int32
decodeI64  :: Decoder s Int64
decodeI128 :: Decoder s Int128

decodeI8 :: forall s. Decoder s Int8
decodeI8   = (forall a b. BitwiseCast a b => a -> b
castBits @Word8  ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeI16 :: forall s. Decoder s Int16
decodeI16  = (forall a b. BitwiseCast a b => a -> b
castBits @Word16 ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeI32 :: forall s. Decoder s Int32
decodeI32  = (forall a b. BitwiseCast a b => a -> b
castBits @Word32 ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeI64 :: forall s. Decoder s Int64
decodeI64  = (forall a b. BitwiseCast a b => a -> b
castBits @Word64 ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeI128 :: forall s. Decoder s Int128
decodeI128 = (forall a b. BitwiseCast a b => a -> b
castBits @Word128) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian

decodeF32  :: Decoder s Float
decodeF64  :: Decoder s Double

decodeF32 :: forall s. Decoder s Float
decodeF32  = (forall a b. BitwiseCast a b => a -> b
castBits @Word32) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian
decodeF64 :: forall s. Decoder s Double
decodeF64  = (forall a b. BitwiseCast a b => a -> b
castBits @Word64) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. ByteSwap a => Decoder s a
decodeLittleEndian

decodeString :: Decoder s Text
decodeString :: forall s. Decoder s Text
decodeString = do
    Word32
len <- forall s. Decoder s Word32
decodeU32
    ByteString
lbs <- forall s. Word32 -> Decoder s ByteString
decodeLargeToken Word32
len
    case ByteString -> Either UnicodeException Text
Text.decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.toStrict ByteString
lbs of
      Right Text
txt -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
txt
      Left  UnicodeException
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show UnicodeException
err)

{-------------------------------------------------------------------------------
  Decoders for composite types mandated by the Borsh spec
-------------------------------------------------------------------------------}

decodeArray :: forall n s a.
     KnownNat n
  => Decoder s a -> Decoder s (FixedSizeArray n a)
decodeArray :: forall (n :: Nat) s a.
KnownNat n =>
Decoder s a -> Decoder s (FixedSizeArray n a)
decodeArray Decoder s a
d = do
    -- Construct mutable array before we start processing elements,
    -- along with a counter for the next element
    MFixedSizeArray n s a
mArr :: MFixedSizeArray n s a <- forall s a. ST s a -> Decoder s a
liftDecoder forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: Nat) a.
(PrimMonad m, KnownNat n) =>
m (MFixedSizeArray n (PrimState m) a)
FSA.new
    STRef s Int
next :: STRef s Int           <- forall s a. ST s a -> Decoder s a
liftDecoder forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef Int
0

    let d' :: Decoder s ()
        d' :: Decoder s ()
d' = Decoder s a
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
b -> forall s a. ST s a -> Decoder s a
liftDecoder forall a b. (a -> b) -> a -> b
$ do
                Int
i <- forall s a. STRef s a -> ST s a
readSTRef STRef s Int
next
                forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s Int
next (forall a. Num a => a -> a -> a
+ Int
1)
                forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
GM.write MFixedSizeArray n s a
mArr Int
i a
b

    forall s. Word32 -> Decoder s () -> Decoder s ()
decodeIncremental_ Word32
count Decoder s ()
d'
    forall s a. ST s a -> Decoder s a
liftDecoder forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
G.freeze MFixedSizeArray n s a
mArr
  where
    count :: Word32
    count :: Word32
count = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)

decodeVec :: Decoder s a -> Decoder s [a]
decodeVec :: forall s a. Decoder s a -> Decoder s [a]
decodeVec Decoder s a
d = forall s. Decoder s Word32
decodeU32 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word32
count -> forall s a. Word32 -> Decoder s a -> Decoder s [a]
decodeIncremental Word32
count Decoder s a
d

decodeOption :: Decoder s a -> Decoder s (Maybe a)
decodeOption :: forall s a. Decoder s a -> Decoder s (Maybe a)
decodeOption Decoder s a
d = do
    Word8
present <- forall s. Decoder s Word8
decodeU8
    case Word8
present of
      Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Word8
1 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
d
      Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected 0 or 1 for option prefix"

decodeHashSet :: Ord a => Decoder s a -> Decoder s (Set a)
decodeHashSet :: forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeHashSet Decoder s a
d = do
    Word32
count <- forall s. Decoder s Word32
decodeU32
    forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Word32 -> Decoder s a -> Decoder s [a]
decodeIncremental Word32
count Decoder s a
d

decodeHashMap :: Ord k => Decoder s k -> Decoder s a -> Decoder s (Map k a)
decodeHashMap :: forall k s a.
Ord k =>
Decoder s k -> Decoder s a -> Decoder s (Map k a)
decodeHashMap Decoder s k
dk Decoder s a
dv = do
    Word32
count <- forall s. Decoder s Word32
decodeU32
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Word32 -> Decoder s a -> Decoder s [a]
decodeIncremental Word32
count Decoder s (k, a)
dPair
  where
    dPair :: Decoder s (k, a)
dPair = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s k
dk forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s a
dv

decodeStruct :: All Top xs => NP (Decoder s) xs -> Decoder s (NP I xs)
decodeStruct :: forall (xs :: [*]) s.
All Top xs =>
NP (Decoder s) xs -> Decoder s (NP I xs)
decodeStruct = forall {l} (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence

decodeEnum :: forall s xss.
     All SListI xss
  => POP (Decoder s) xss -> Decoder s (SOP I xss)
decodeEnum :: forall s (xss :: [[*]]).
All SListI xss =>
POP (Decoder s) xss -> Decoder s (SOP I xss)
decodeEnum =
      [(Word8, Decoder s (SOP I xss))] -> Decoder s (SOP I xss)
selectDecoder
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a -> f''' a)
-> Prod h f xs
-> Prod h f' xs
-> h f'' xs
-> h f''' xs
hczipWith3
        (forall {k} (t :: k). Proxy t
Proxy @SListI)
        (\(K Word8
ix) (Fn NP I a -> K (NS (NP I) xss) a
inj) NP (Decoder s) a
ds -> forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ (Word8
ix, forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). K a b -> a
unK forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I a -> K (NS (NP I) xss) a
inj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {l} (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence NP (Decoder s) a
ds))
        forall k (xs :: [k]). SListI xs => NP (K Word8) xs
indices
        (forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections :: NP (Injection (NP I) xss) xss)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (xss :: [[k]]). POP f xss -> NP (NP f) xss
unPOP
  where
    selectDecoder :: [(Word8, Decoder s (SOP I xss))] -> Decoder s (SOP I xss)
    selectDecoder :: [(Word8, Decoder s (SOP I xss))] -> Decoder s (SOP I xss)
selectDecoder [(Word8, Decoder s (SOP I xss))]
decs = do
        Word8
n <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Word8
decodeU8
        forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word8
n [(Word8, Decoder s (SOP I xss))]
decs
      where
        err :: String
        err :: String
err = String
"Expected index < " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Decoder s (SOP I xss))]
decs)

{-------------------------------------------------------------------------------
  Decoders for Haskell types not mandated by the Borsh spec
-------------------------------------------------------------------------------}

-- ByteStrings

decodeLazyByteString :: Decoder s L.ByteString
decodeLazyByteString :: forall s. Decoder s ByteString
decodeLazyByteString = do
    Word32
len <- forall s. Decoder s Word32
decodeU32
    forall s. Word32 -> Decoder s ByteString
decodeLargeToken Word32
len

decodeStrictByteString :: Decoder s S.ByteString
decodeStrictByteString :: forall s. Decoder s ByteString
decodeStrictByteString = do
    Word32
len <- forall s. Decoder s Word32
decodeU32
    ByteString -> ByteString
L.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Word32 -> Decoder s ByteString
decodeLargeToken Word32
len

-- Char, Bool

decodeChar :: Decoder s Char
decodeChar :: forall s. Decoder s Char
decodeChar = Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Word32
decodeU32

decodeBool :: Decoder s Bool
decodeBool :: forall s. Decoder s Bool
decodeBool = forall s. Decoder s Word8
decodeU8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected 0 or 1 while decoding Bool"