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

import Data.Sequence (fromList, (|>))
import Data.Singletons (pattern FromSing, Sing, SingI, withSingI)
import Tezos.Common.Binary (decode, encode)
import Tezos.V005.Micheline
  (Annotation(..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))

import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT')
import Michelson.Interpret.Unpack (unpackInstr', unpackValue')
import Michelson.Typed
  (FullContract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, pnNotes, pnRootAnn)
import Michelson.Typed.Scope (UnpackedValScope)
import Michelson.Untyped.Annotation (Annotation(..), RootAnn)
import Michelson.Untyped.Instr (ExpandedOp)

-- | 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 = ByteString -> Expression
forall a. TezosBinary a => ByteString -> a
decode (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)) =
    ByteString -> Expression
forall a. TezosBinary a => ByteString -> a
decode (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 = ByteString -> Expression
forall a. TezosBinary a => ByteString -> a
decode (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 = ByteString -> Expression
forall a. TezosBinary a => ByteString -> a
decode (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 (FullContract cp st) where
  toExpression :: FullContract cp st -> Expression
toExpression FullContract{..} = Seq Expression -> Expression
Expression_Seq (Seq Expression -> Expression) -> Seq Expression -> Expression
forall a b. (a -> b) -> a -> b
$ [Expression] -> Seq Expression
forall a. [a] -> Seq a
fromList
    [ MichelinePrimAp -> Expression
Expression_Prim (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
fcParamNotes) (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
fcParamNotes
                ])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    , MichelinePrimAp -> Expression
Expression_Prim (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
fcStoreNotes])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    , MichelinePrimAp -> Expression
Expression_Prim (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
fcCode])
      ([Annotation] -> Seq Annotation
forall a. [a] -> Seq a
fromList [])
    ]
    where
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
addRootAnnToExpression rootAnn :: RootAnn
rootAnn = \case
        Expression_Prim p :: MichelinePrimAp
p -> MichelinePrimAp -> Expression
Expression_Prim
          MichelinePrimAp
p{ _michelinePrimAps_annots :: Seq Annotation
_michelinePrimAps_annots = MichelinePrimAp -> Seq Annotation
_michelinePrimAps_annots MichelinePrimAp
p Seq Annotation -> Annotation -> Seq Annotation
forall a. Seq a -> a -> Seq a
|>
             (Text -> Annotation
Annotation_Field (Text -> Annotation) -> Text -> Annotation
forall a b. (a -> b) -> a -> b
$ RootAnn -> Text
forall k (tag :: k). Annotation tag -> Text
unAnnotation (RootAnn -> Text) -> RootAnn -> Text
forall a b. (a -> b) -> a -> b
$ 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
  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
forall a. TezosBinary a => a -> ByteString
encode

instance UnpackedValScope t => 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
forall a. TezosBinary a => a -> ByteString
encode