-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{- | Module, carrying logic of @UNPACK@ instruction.

This is nearly symmetric to adjacent Pack.hs module.

When implementing this the following sources were used:

* https://pastebin.com/8gfXaRvp

* https://gitlab.com/tezos/tezos/-/blob/767de2b6665ec2cc21e41e6348f8a0b369d26450/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501

* https://github.com/tezbridge/tezbridge-crypto/blob/f7d93d8d04201557972e839967758cff5bbe5345/PsddFKi3/codec.js#L513

-}
module Michelson.Interpret.Unpack
  ( UnpackError (..)
  , unpackInstr'
  , unpackUValue'
  , unpackValue'
  ) where

import Prelude hiding (EQ, Ordering(..), get)

import qualified Data.ByteString as BS
import Data.Constraint (Dict(..))
import Fmt (pretty)

import Michelson.Typed (UnpackedValScope)
import qualified Michelson.Typed as T
import Michelson.Untyped
import qualified Michelson.Untyped as U
import Morley.Micheline.Binary (eitherDecodeExpression)
import Morley.Micheline.Class (FromExpression(..))
import Util.Binary

{- Implementation notes:

* We need to know which exact type we unpack to.
For instance, serialized signatures are indistinguishable from
plain serialized bytes, so if we want to return "Value" (typed or untyped),
we need to know currently expected type. The reference implementation does
the same.

* It occurred to be easier to decode to typed values and untyped instructions.
When decoding lambda, we type check given instruction, and when decoding
@PUSH@ call we untype decoded value.
One may say that this gives unreasonable performance overhead, but with the
current definition of "Value" types (typed and untyped) we cannot avoid it
anyway, because when deserializing bytearray-like data (keys, signatures, ...),
we have to convert raw bytes to human-readable 'Text' and later parse them
to bytes back at type check stage.
We console ourselves that lambdas are rarely packed.

-}

-- | Deserialize bytes into the given value.
-- Suitable for @UNPACK@ operation only.
unpackValue'
  :: forall t. (UnpackedValScope t)
  => ByteString -> Either UnpackError (T.Value t)
unpackValue' :: ByteString -> Either UnpackError (Value t)
unpackValue' = FromExpression (Value t) =>
ByteString -> Either UnpackError (Value t)
forall t. FromExpression t => ByteString -> Either UnpackError t
unpackImpl @(T.Value t)
  where
    _reallyNeedThisConstraint :: Dict (UnpackedValScope t)
_reallyNeedThisConstraint = UnpackedValScope t => Dict (UnpackedValScope t)
forall (a :: Constraint). a => Dict a
Dict @(UnpackedValScope t)

-- | Deserialize an instruction into the given value.
unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]
unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]
unpackInstr' = FromExpression [ExpandedOp] =>
ByteString -> Either UnpackError [ExpandedOp]
forall t. FromExpression t => ByteString -> Either UnpackError t
unpackImpl @([ExpandedOp])

-- | Deserialize bytes into 'Untyped.Value'.
unpackUValue' :: ByteString -> Either UnpackError U.Value
unpackUValue' :: ByteString -> Either UnpackError Value
unpackUValue' = FromExpression Value => ByteString -> Either UnpackError Value
forall t. FromExpression t => ByteString -> Either UnpackError t
unpackImpl @U.Value

unpackImpl :: forall t. (FromExpression t)
           => ByteString
           -> Either UnpackError t
unpackImpl :: ByteString -> Either UnpackError t
unpackImpl ByteString
bs = do
  (Word8
tag, ByteString
bs') <- UnpackError
-> Maybe (Word8, ByteString)
-> Either UnpackError (Word8, ByteString)
forall l r. l -> Maybe r -> Either l r
maybeToRight (Text -> UnpackError
UnpackError Text
"Empty bytes") (ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs)
  Bool -> Either UnpackError () -> Either UnpackError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
tag Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x05) (Either UnpackError () -> Either UnpackError ())
-> (Text -> Either UnpackError ()) -> Text -> Either UnpackError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnpackError -> Either UnpackError ()
forall a b. a -> Either a b
Left (UnpackError -> Either UnpackError ())
-> (Text -> UnpackError) -> Text -> Either UnpackError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnpackError
UnpackError (Text -> Either UnpackError ()) -> Text -> Either UnpackError ()
forall a b. (a -> b) -> a -> b
$
    Text
"Unexpected tag: '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Word8 -> Text
forall b a. (Show a, IsString b) => a -> b
show Word8
tag) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'. '0x05' tag expected."
  Expression
expr <- ByteString -> Either UnpackError Expression
eitherDecodeExpression ByteString
bs'
  (FromExpressionError -> Either UnpackError t)
-> (t -> Either UnpackError t)
-> Either FromExpressionError t
-> Either UnpackError t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UnpackError -> Either UnpackError t
forall a b. a -> Either a b
Left (UnpackError -> Either UnpackError t)
-> (FromExpressionError -> UnpackError)
-> FromExpressionError
-> Either UnpackError t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnpackError
UnpackError (Text -> UnpackError)
-> (FromExpressionError -> Text)
-> FromExpressionError
-> UnpackError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromExpressionError -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) t -> Either UnpackError t
forall a b. b -> Either a b
Right (Either FromExpressionError t -> Either UnpackError t)
-> Either FromExpressionError t -> Either UnpackError t
forall a b. (a -> b) -> a -> b
$ Expression -> Either FromExpressionError t
forall a.
FromExpression a =>
Expression -> Either FromExpressionError a
fromExpression @t Expression
expr