Contract.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Michelson contract in untyped model.

module Michelson.Untyped.Contract
  ( EntriesOrder (..)
  , canonicalEntriesOrder
  , entriesOrderToInt
  , mapEntriesOrdered

  , ContractBlock (..)
  , orderContractBlock

  , Contract' (..)
  , Storage
  ) where

import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.Default (Default(..))
import Fmt (Buildable(build))
import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))

import Michelson.Printer.Util
  (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)
import Michelson.Untyped.Type (ParameterType(..), Type(..))
import Util.Aeson

-- | Top-level entries order of the contract.
-- This is preserved due to the fact that it affects
-- the output of pretty-printing and serializing contract.

-- Each constructors is created by the order of the first letter of
-- @parameter@, @storage@, and @code@.
--
-- For example, @PSC@ would be @parameter@, @storage@ and @code@,
-- @CPS@ would be @code@, @parameter@,and @storage@, and so on.
data EntriesOrder
  = PSC
  | PCS
  | SPC
  | SCP
  | CSP
  | CPS
  deriving stock (Bounded, Data, Enum, Eq, Generic, Show)

instance Default EntriesOrder where
  def = canonicalEntriesOrder
instance NFData EntriesOrder

-- | The canonical entries order which is ordered as follow:
-- @parameter@, @storage@, and @code@.
canonicalEntriesOrder :: EntriesOrder
canonicalEntriesOrder = PSC

-- | @(Int, Int, Int)@ is the positions of @parameter@, @storage@, and @code@
-- respectively.
entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)
entriesOrderToInt = \case
  PSC -> (0, 1, 2)
  PCS -> (0, 2, 1)
  SPC -> (1, 0, 2)
  SCP -> (1, 2, 0)
  CSP -> (2, 1, 0)
  CPS -> (2, 0, 1)

-- | Contract block, convenient when parsing
data ContractBlock op
  = CBParam ParameterType
  | CBStorage Type
  | CBCode [op]
  deriving stock (Eq, Show)

orderContractBlock :: (ContractBlock op, ContractBlock op, ContractBlock op) -> Maybe (Contract' op)
orderContractBlock = \case
  (CBParam   p, CBStorage s, CBCode    c) -> Just $ Contract p s c PSC
  (CBParam   p, CBCode    c, CBStorage s) -> Just $ Contract p s c PCS
  (CBStorage s, CBParam   p, CBCode    c) -> Just $ Contract p s c SPC
  (CBStorage s, CBCode    c, CBParam   p) -> Just $ Contract p s c SCP
  (CBCode    c, CBStorage s, CBParam   p) -> Just $ Contract p s c CSP
  (CBCode    c, CBParam   p, CBStorage s) -> Just $ Contract p s c CPS
  _                                       -> Nothing

-- | Map each contract fields by the given function and sort the output
-- based on the 'EntriesOrder'.
mapEntriesOrdered
  :: Contract' op
  -> (ParameterType -> a)
  -> (Storage -> a)
  -> ([op] -> a)
  -> [a]
mapEntriesOrdered Contract{..} fParam fStorage fCode =
  fmap snd
    $ sortWith fst
        [ (paramPos, fParam contractParameter)
        , (storagePos, fStorage contractStorage)
        , (codePos, fCode contractCode)
        ]
  where
    (paramPos, storagePos, codePos) = entriesOrderToInt entriesOrder

type Storage = Type
data Contract' op = Contract
  { contractParameter :: ParameterType
  , contractStorage :: Storage
  , contractCode :: [op]
  , entriesOrder :: EntriesOrder
  } deriving stock (Eq, Show, Functor, Data, Generic)

instance NFData op => NFData (Contract' op)

instance (RenderDoc op) => RenderDoc (Contract' op) where
  renderDoc pn contract =
    assertParensNotNeeded pn
      $ foldr (<$$>) (text "")
      $ mapEntriesOrdered contract
        (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi)
        (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi)
        (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))

instance RenderDoc op => Buildable (Contract' op) where
  build = buildRenderDoc

deriveJSON morleyAesonOptions ''EntriesOrder
deriveJSON morleyAesonOptions ''Contract'