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

-- | Module that provides type classes for converting to and from low-level
-- Micheline representation.
module Morley.Micheline.Class
  ( ToExpression (..)
  , FromExpressionError (..)
  , FromExpression (..)
  ) where

import qualified Data.ByteString.Lazy as LBS
import Data.Sequence (fromList, (|>))
import Data.Singletons (pattern FromSing, Sing, SingI, withSingI)
import Fmt (Buildable(..), pretty)

import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT')
import Michelson.Interpret.Unpack
  (UnpackError, decodeContract, decodeType, unpackInstr', unpackValue')
import Michelson.Typed
  (pattern AsUType, Contract(..), HasNoOp, Instr(..), KnownT, Notes(..), T(..), Value, Value'(..),
  fromUType, pnNotes, pnRootAnn, rfAnyInstr)
import Michelson.Typed.Instr (mapEntriesOrdered)
import Michelson.Typed.Scope (UnpackedValScope)
import qualified Michelson.Untyped as Untyped
import Michelson.Untyped.Annotation (RootAnn, noAnn)
import Michelson.Untyped.Instr (ExpandedOp)
import Morley.Micheline.Binary (decodeExpression, encodeExpression)
import Morley.Micheline.Expression
  (Annotation(..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))
import Util.Binary (launchGet)

-- | Type class that provides an ability to convert
-- something to Micheline Expression.
class ToExpression a where
  toExpression :: a -> Expression

instance ToExpression (Instr inp out) where
  toExpression :: Instr inp out -> Expression
toExpression = HasCallStack => ByteString -> Expression
ByteString -> Expression
decodeExpression (ByteString -> Expression)
-> (Instr inp out -> ByteString) -> Instr inp out -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instr inp out -> ByteString
forall (inp :: [T]) (out :: [T]). Instr inp out -> ByteString
packCode'

instance ToExpression T where
  toExpression :: T -> Expression
toExpression (FromSing (ts :: Sing t)) =
    HasCallStack => ByteString -> Expression
ByteString -> Expression
decodeExpression (ByteString -> Expression) -> ByteString -> Expression
forall a b. (a -> b) -> a -> b
$ Sing a -> (SingI a => ByteString) -> ByteString
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing a
ts ((SingI a => ByteString) -> ByteString)
-> (SingI a => ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (SingI a => ByteString
forall (t :: T). SingI t => ByteString
packT' @t)

instance SingI t => ToExpression (Notes t) where
  toExpression :: Notes t -> Expression
toExpression = HasCallStack => ByteString -> Expression
ByteString -> Expression
decodeExpression (ByteString -> Expression)
-> (Notes t -> ByteString) -> Notes t -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notes t -> ByteString
forall (t :: T). SingI t => Notes t -> ByteString
packNotedT'

instance ToExpression Untyped.Type where
  toExpression :: Type -> Expression
toExpression (AsUType notes :: Notes t
notes) = Notes t -> Expression
forall a. ToExpression a => a -> Expression
toExpression Notes t
notes

instance (SingI t, HasNoOp t) => ToExpression (Value t) where
  toExpression :: Value t -> Expression
toExpression = HasCallStack => ByteString -> Expression
ByteString -> Expression
decodeExpression (ByteString -> Expression)
-> (Value t -> ByteString) -> Value t -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value t -> ByteString
forall (t :: T). (SingI t, HasNoOp t) => Value t -> ByteString
encodeValue'

instance ToExpression (Contract cp st) where
  toExpression :: Contract cp st -> Expression
toExpression contract :: Contract cp st
contract@Contract{..} = Seq Expression -> Expression
ExpressionSeq (Seq Expression -> Expression) -> Seq Expression -> Expression
forall a b. (a -> b) -> a -> b
$ [Expression] -> Seq Expression
forall a. [a] -> Seq a
fromList ([Expression] -> Seq Expression) -> [Expression] -> Seq Expression
forall a b. (a -> b) -> a -> b
$ Contract cp st
-> (ParamNotes cp -> Expression)
-> (Notes st -> Expression)
-> (ContractCode cp st -> Expression)
-> [Expression]
forall (cp :: T) (st :: T) a.
Contract cp st
-> (ParamNotes cp -> a)
-> (Notes st -> a)
-> (ContractCode cp st -> a)
-> [a]
mapEntriesOrdered Contract cp st
contract
    (\param :: ParamNotes cp
param -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression) -> MichelinePrimAp -> Expression
forall a b. (a -> b) -> a -> b
$
        MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (Text -> MichelinePrimitive
MichelinePrimitive "parameter")
        ([Expression] -> Seq Expression
forall a. [a] -> Seq a
fromList [ HasCallStack => RootAnn -> Expression -> Expression
RootAnn -> Expression -> Expression
addRootAnnToExpression (ParamNotes cp -> RootAnn
forall (t :: T). ParamNotes t -> RootAnn
pnRootAnn ParamNotes cp
param) (Expression -> Expression) -> Expression -> Expression
forall a b. (a -> b) -> a -> b
$
                    Notes cp -> Expression
forall a. ToExpression a => a -> Expression
toExpression (Notes cp -> Expression) -> Notes cp -> Expression
forall a b. (a -> b) -> a -> b
$ ParamNotes cp -> Notes cp
forall (t :: T). ParamNotes t -> Notes t
pnNotes ParamNotes cp
param
                  ])
        ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    )
    (\store :: Notes st
store -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression) -> MichelinePrimAp -> Expression
forall a b. (a -> b) -> a -> b
$
        MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (Text -> MichelinePrimitive
MichelinePrimitive "storage")
        ([Expression] -> Seq Expression
forall a. [a] -> Seq a
fromList [Notes st -> Expression
forall a. ToExpression a => a -> Expression
toExpression (Notes st -> Expression) -> Notes st -> Expression
forall a b. (a -> b) -> a -> b
$ Notes st
store])
        ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    )
    (\code :: ContractCode cp st
code -> MichelinePrimAp -> Expression
ExpressionPrim (MichelinePrimAp -> Expression) -> MichelinePrimAp -> Expression
forall a b. (a -> b) -> a -> b
$
        MichelinePrimitive
-> Seq Expression -> Seq Annotation -> MichelinePrimAp
MichelinePrimAp (Text -> MichelinePrimitive
MichelinePrimitive "code")
        ([Expression] -> Seq Expression
forall a. [a] -> Seq a
fromList [ContractCode cp st -> Expression
forall a. ToExpression a => a -> Expression
toExpression ContractCode cp st
code])
        ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    )
    where
      addRootAnnToExpression :: HasCallStack =>
        RootAnn -> Expression -> Expression
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
addRootAnnToExpression rootAnn :: RootAnn
rootAnn expr :: Expression
expr = case Expression
expr of
        ExpressionPrim p :: MichelinePrimAp
p
          | RootAnn
rootAnn RootAnn -> RootAnn -> Bool
forall a. Eq a => a -> a -> Bool
/= RootAnn
forall k (a :: k). Annotation a
noAnn -> MichelinePrimAp -> Expression
ExpressionPrim MichelinePrimAp
p
            { mpaAnnots :: Seq Annotation
mpaAnnots = MichelinePrimAp -> Seq Annotation
mpaAnnots MichelinePrimAp
p Seq Annotation -> Annotation -> Seq Annotation
forall a. Seq a -> a -> Seq a
|> RootAnn -> Annotation
AnnotationField RootAnn
rootAnn
            }
          | Bool
otherwise -> Expression
expr
        -- Currently this error can't happen because parameter type
        -- must be a Micheline primitive. If it ever changes, we
        -- would like to notice it ASAP and update this place.
        _ -> Text -> Expression
forall a. HasCallStack => Text -> a
error (Text -> Expression) -> Text -> Expression
forall a b. (a -> b) -> a -> b
$ "parameter is not a primitive: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression -> Text
forall b a. (Show a, IsString b) => a -> b
show Expression
expr

-- | Errors that can happen when we convert an 'Expression' to our
-- data type.
data FromExpressionError = FromExpressionError UnpackError
  deriving stock (Int -> FromExpressionError -> ShowS
[FromExpressionError] -> ShowS
FromExpressionError -> String
(Int -> FromExpressionError -> ShowS)
-> (FromExpressionError -> String)
-> ([FromExpressionError] -> ShowS)
-> Show FromExpressionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FromExpressionError] -> ShowS
$cshowList :: [FromExpressionError] -> ShowS
show :: FromExpressionError -> String
$cshow :: FromExpressionError -> String
showsPrec :: Int -> FromExpressionError -> ShowS
$cshowsPrec :: Int -> FromExpressionError -> ShowS
Show, FromExpressionError -> FromExpressionError -> Bool
(FromExpressionError -> FromExpressionError -> Bool)
-> (FromExpressionError -> FromExpressionError -> Bool)
-> Eq FromExpressionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FromExpressionError -> FromExpressionError -> Bool
$c/= :: FromExpressionError -> FromExpressionError -> Bool
== :: FromExpressionError -> FromExpressionError -> Bool
$c== :: FromExpressionError -> FromExpressionError -> Bool
Eq)

instance Buildable FromExpressionError where
  build :: FromExpressionError -> Builder
build (FromExpressionError err :: UnpackError
err) = UnpackError -> Builder
forall p. Buildable p => p -> Builder
build UnpackError
err

instance Exception FromExpressionError where
  displayException :: FromExpressionError -> String
displayException = FromExpressionError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

-- | Type class that provides the ability to convert
-- something from a Micheline Expression.
class FromExpression a where
  fromExpression :: Expression -> Either FromExpressionError a

instance UnpackedValScope t => FromExpression (Value t) where
  -- | `05` is the prefix for serialized Michelson value.
  fromExpression :: Expression -> Either FromExpressionError (Value t)
fromExpression =
    (UnpackError -> FromExpressionError)
-> Either UnpackError (Value t)
-> Either FromExpressionError (Value t)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first UnpackError -> FromExpressionError
FromExpressionError (Either UnpackError (Value t)
 -> Either FromExpressionError (Value t))
-> (Expression -> Either UnpackError (Value t))
-> Expression
-> Either FromExpressionError (Value t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnpackError (Value t)
forall (t :: T).
UnpackedValScope t =>
ByteString -> Either UnpackError (Value t)
unpackValue' (ByteString -> Either UnpackError (Value t))
-> (Expression -> ByteString)
-> Expression
-> Either UnpackError (Value t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("\05" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> (Expression -> ByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> ByteString
encodeExpression

instance FromExpression [ExpandedOp] where
  fromExpression :: Expression -> Either FromExpressionError [ExpandedOp]
fromExpression = (UnpackError -> FromExpressionError)
-> Either UnpackError [ExpandedOp]
-> Either FromExpressionError [ExpandedOp]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first UnpackError -> FromExpressionError
FromExpressionError (Either UnpackError [ExpandedOp]
 -> Either FromExpressionError [ExpandedOp])
-> (Expression -> Either UnpackError [ExpandedOp])
-> Expression
-> Either FromExpressionError [ExpandedOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnpackError [ExpandedOp]
unpackInstr' (ByteString -> Either UnpackError [ExpandedOp])
-> (Expression -> ByteString)
-> Expression
-> Either UnpackError [ExpandedOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> ByteString
encodeExpression

instance FromExpression Untyped.Contract where
  fromExpression :: Expression -> Either FromExpressionError Contract
fromExpression =
    (UnpackError -> FromExpressionError)
-> Either UnpackError Contract
-> Either FromExpressionError Contract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first UnpackError -> FromExpressionError
FromExpressionError (Either UnpackError Contract
 -> Either FromExpressionError Contract)
-> (Expression -> Either UnpackError Contract)
-> Expression
-> Either FromExpressionError Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get Contract -> LByteString -> Either UnpackError Contract
forall a. Get a -> LByteString -> Either UnpackError a
launchGet Get Contract
decodeContract (LByteString -> Either UnpackError Contract)
-> (Expression -> LByteString)
-> Expression
-> Either UnpackError Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ByteString -> LByteString
LBS.fromStrict (ByteString -> LByteString)
-> (Expression -> ByteString) -> Expression -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> ByteString
encodeExpression

instance FromExpression Untyped.Type where
  fromExpression :: Expression -> Either FromExpressionError Type
fromExpression =
    (UnpackError -> FromExpressionError)
-> Either UnpackError Type -> Either FromExpressionError Type
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first UnpackError -> FromExpressionError
FromExpressionError (Either UnpackError Type -> Either FromExpressionError Type)
-> (Expression -> Either UnpackError Type)
-> Expression
-> Either FromExpressionError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Get Type -> LByteString -> Either UnpackError Type
forall a. Get a -> LByteString -> Either UnpackError a
launchGet Get Type
decodeType (LByteString -> Either UnpackError Type)
-> (Expression -> LByteString)
-> Expression
-> Either UnpackError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ByteString -> LByteString
LBS.fromStrict (ByteString -> LByteString)
-> (Expression -> ByteString) -> Expression -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Expression -> ByteString
encodeExpression

instance FromExpression T where
  fromExpression :: Expression -> Either FromExpressionError T
fromExpression =
    (Type -> T)
-> Either FromExpressionError Type -> Either FromExpressionError T
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Type -> T
fromUType (Either FromExpressionError Type -> Either FromExpressionError T)
-> (Expression -> Either FromExpressionError Type)
-> Expression
-> Either FromExpressionError T
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromExpression Type =>
Expression -> Either FromExpressionError Type
forall a.
FromExpression a =>
Expression -> Either FromExpressionError a
fromExpression @Untyped.Type

-- Note: we should generalize this to work for any instruction,
-- not just lambdas (i.e. instructions with one input and one output).
instance (KnownT inp, KnownT out) => FromExpression (Instr '[inp] '[out]) where
  fromExpression :: Expression -> Either FromExpressionError (Instr '[inp] '[out])
fromExpression expr :: Expression
expr =
    Expression -> Either FromExpressionError (Value ('TLambda inp out))
forall a.
FromExpression a =>
Expression -> Either FromExpressionError a
fromExpression @(Value ('TLambda inp out)) Expression
expr Either FromExpressionError (Value ('TLambda inp out))
-> (Value ('TLambda inp out) -> Instr '[inp] '[out])
-> Either FromExpressionError (Instr '[inp] '[out])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      VLam instr :: RemFail Instr '[inp] '[out]
instr -> RemFail Instr '[inp] '[out] -> Instr '[inp] '[out]
forall k (instr :: k -> k -> *) (i :: k) (o :: k).
RemFail instr i o -> instr i o
rfAnyInstr RemFail Instr '[inp] '[out]
instr