-- 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 (..)
  , FromExpression (..)
  ) where

import Data.Sequence (fromList, (|>))
import Data.Singletons (pattern FromSing, Sing, SingI, withSingI)

import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT')
import Michelson.Interpret.Unpack (unpackInstr', unpackValue')
import Michelson.Typed
  (Contract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, pnNotes, pnRootAnn)
import Michelson.Typed.Scope (UnpackedValScope)
import Michelson.Untyped.Annotation (RootAnn, convAnn)
import Michelson.Untyped.Instr (ExpandedOp)
import Morley.Micheline.Binary (decodeExpression, encodeExpression)
import Morley.Micheline.Expression (Annotation (..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))

-- | 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 (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{..} = 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
    [ 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 [ RootAnn -> Expression -> Expression
addRootAnnToExpression (ParamNotes cp -> RootAnn
forall (t :: T). ParamNotes t -> RootAnn
pnRootAnn ParamNotes cp
cParamNotes) (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
cParamNotes
                ])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    , 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
cStoreNotes])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    , 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
cCode])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    ]
    where
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
addRootAnnToExpression rootAnn :: RootAnn
rootAnn = \case
        ExpressionPrim p :: MichelinePrimAp
p -> 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
|>
             (FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation) -> FieldAnn -> Annotation
forall a b. (a -> b) -> a -> b
$ RootAnn -> FieldAnn
forall k1 k2 (tag1 :: k1) (tag2 :: k2).
Annotation tag1 -> Annotation tag2
convAnn RootAnn
rootAnn)
           }
        x :: Expression
x -> Expression
x

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

instance UnpackedValScope t => FromExpression (Value t) where
  -- | `05` is the prefix for serialized Michelson value.
  fromExpression :: Expression -> Maybe (Value t)
fromExpression = Either UnpackError (Value t) -> Maybe (Value t)
forall l r. Either l r -> Maybe r
rightToMaybe (Either UnpackError (Value t) -> Maybe (Value t))
-> (Expression -> Either UnpackError (Value t))
-> Expression
-> Maybe (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 -> Maybe [ExpandedOp]
fromExpression = Either UnpackError [ExpandedOp] -> Maybe [ExpandedOp]
forall l r. Either l r -> Maybe r
rightToMaybe (Either UnpackError [ExpandedOp] -> Maybe [ExpandedOp])
-> (Expression -> Either UnpackError [ExpandedOp])
-> Expression
-> Maybe [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