Micheline.hs

-- 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
  ( 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
  (Contract(..), 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 = decode . packCode'

instance ToExpression T where
  toExpression (FromSing (ts :: Sing t)) =
    decode $ withSingI ts $ (packT' @t)

instance SingI t => ToExpression (Notes t) where
  toExpression = decode . packNotedT'

instance (SingI t, HasNoOp t) => ToExpression (Value t) where
  toExpression = decode . encodeValue'

instance ToExpression (Contract cp st) where
  toExpression Contract{..} = Expression_Seq $ fromList
    [ Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "parameter")
      (fromList [ addRootAnnToExpression (pnRootAnn cParamNotes) $
                  toExpression $ pnNotes cParamNotes
                ])
      (fromList [])
    , Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "storage")
      (fromList [toExpression $ cStoreNotes])
      (fromList [])
    , Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "code")
      (fromList [toExpression cCode])
      (fromList [])
    ]
    where
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
      addRootAnnToExpression rootAnn = \case
        Expression_Prim p -> Expression_Prim
          p{ _michelinePrimAps_annots = _michelinePrimAps_annots p |>
             (Annotation_Field $ unAnnotation $ rootAnn)
           }
        x -> 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 = rightToMaybe . unpackValue' . ("\05" <>) . encode

instance UnpackedValScope t => FromExpression [ExpandedOp] where
  fromExpression = rightToMaybe . unpackInstr' . encode