-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{- | 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 Morley.Michelson.Interpret.Unpack
  ( UnpackError (..)
  , unpackInstr'
  , unpackUValue'
  , unpackValue'
  ) where

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

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

import Morley.Micheline.Binary (eitherDecodeExpression)
import Morley.Micheline.Class (FromExpression, fromExpression)
import Morley.Michelson.Typed (UnpackedValScope)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped
import Morley.Michelson.Untyped qualified as U
import Morley.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' :: forall (t :: T).
UnpackedValScope t =>
ByteString -> Either UnpackError (Value t)
unpackValue' = forall t. FromExpression t => ByteString -> Either UnpackError t
unpackImpl @(T.Value t)
  where
    _reallyNeedThisConstraint :: Dict (UnpackedValScope t)
_reallyNeedThisConstraint = 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' = forall t. FromExpression t => ByteString -> Either UnpackError t
unpackImpl @([ExpandedOp])

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

unpackImpl :: forall t. (FromExpression t)
           => ByteString
           -> Either UnpackError t
unpackImpl :: forall t. FromExpression t => 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. (PrettyShow 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 -> UnpackError)
-> Either FromExpressionError t -> Either UnpackError t
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (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) (Either FromExpressionError t -> Either UnpackError t)
-> Either FromExpressionError t -> Either UnpackError t
forall a b. (a -> b) -> a -> b
$ forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression @t Expression
expr