Class.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.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 = decodeExpression . packCode'

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

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

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

instance ToExpression (Contract cp st) where
  toExpression Contract{..} = ExpressionSeq $ fromList
    [ ExpressionPrim $
      MichelinePrimAp (MichelinePrimitive "parameter")
      (fromList [ addRootAnnToExpression (pnRootAnn cParamNotes) $
                  toExpression $ pnNotes cParamNotes
                ])
      (fromList [])
    , ExpressionPrim $
      MichelinePrimAp (MichelinePrimitive "storage")
      (fromList [toExpression $ cStoreNotes])
      (fromList [])
    , ExpressionPrim $
      MichelinePrimAp (MichelinePrimitive "code")
      (fromList [toExpression cCode])
      (fromList [])
    ]
    where
      addRootAnnToExpression :: RootAnn -> Expression -> Expression
      addRootAnnToExpression rootAnn = \case
        ExpressionPrim p -> ExpressionPrim
          p{ mpaAnnots = mpaAnnots p |>
             (AnnotationField $ convAnn 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
  -- | `05` is the prefix for serialized Michelson value.
  fromExpression = rightToMaybe . unpackValue' . ("\05" <>) . encodeExpression

instance FromExpression [ExpandedOp] where
  fromExpression = rightToMaybe . unpackInstr' . encodeExpression