Micheline.hs

-- | 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 = 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 (FullContract cp st) where
  toExpression FullContract{..} = Expression_Seq $ fromList
    [ Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "parameter")
      (fromList [ addRootAnnToExpression (pnRootAnn fcParamNotes) $
                  toExpression $ pnNotes fcParamNotes
                ])
      (fromList [])
    , Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "storage")
      (fromList [toExpression $ fcStoreNotes])
      (fromList [])
    , Expression_Prim $
      MichelinePrimAp (MichelinePrimitive "code")
      (fromList [toExpression fcCode])
      (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