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

import qualified Data.ByteString.Lazy as LBS
import Data.Sequence (fromList, (|>))
import Data.Singletons (pattern FromSing, Sing, SingI, withSingI)
import Fmt (Buildable(..), pretty)

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

-- | 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@Contract{..} = ExpressionSeq $ fromList $ mapEntriesOrdered contract
    (\param -> ExpressionPrim $
        MichelinePrimAp (MichelinePrimitive "parameter")
        (fromList [ addRootAnnToExpression (pnRootAnn param) $
                    toExpression $ pnNotes param
                  ])
        (fromList [])
    )
    (\store -> ExpressionPrim $
        MichelinePrimAp (MichelinePrimitive "storage")
        (fromList [toExpression $ store])
        (fromList [])
    )
    (\code -> ExpressionPrim $
        MichelinePrimAp (MichelinePrimitive "code")
        (fromList [toExpression code])
        (fromList [])
    )
    where
      addRootAnnToExpression :: HasCallStack =>
        RootAnn -> Expression -> Expression
      addRootAnnToExpression rootAnn expr = case expr of
        ExpressionPrim p
          | rootAnn /= noAnn -> ExpressionPrim p
            { mpaAnnots = mpaAnnots p |>
             (AnnotationField $ convAnn rootAnn)
            }
          | otherwise -> expr
        -- Currently this error can't happen because parameter type
        -- must be a Micheline primitive. If it ever changes, we
        -- would like to notice it ASAP and update this place.
        _ -> error $ "parameter is not a primitive: " <> show expr

-- | Errors that can happen when we convert an 'Expression' to our
-- data type.
data FromExpressionError = FromExpressionError UnpackError
  deriving stock (Show, Eq)

instance Buildable FromExpressionError where
  build (FromExpressionError err) = build err

instance Exception FromExpressionError where
  displayException = pretty

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

instance UnpackedValScope t => FromExpression (Value t) where
  -- | `05` is the prefix for serialized Michelson value.
  fromExpression =
    first FromExpressionError . unpackValue' . ("\05" <>) . encodeExpression

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

instance FromExpression Untyped.Contract where
  fromExpression =
    first FromExpressionError . launchGet decodeContract .
    LBS.fromStrict . encodeExpression