MichelinePrimitive.hs

-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DeriveLift #-}

-- | Micheline primitive datatype
module Morley.Micheline.Expression.Internal.MichelinePrimitive
  ( module Morley.Micheline.Expression.Internal.MichelinePrimitive
  ) where

import Data.Aeson qualified as Aeson
import Data.Char (isDigit, isLower, isUpper)
import Data.Data (Data)
import Data.Text qualified as T
import Fmt (Buildable(..), pretty)
import Language.Haskell.TH.Syntax (Lift)

import Morley.Util.Sing (genSingletonsType)

data MichelinePrimitive
  -- NOTE: The order of constructors in this datatype *matters*!
  --
  -- The position of each constructor determines which binary code it gets
  -- packed to. E.g.
  --   * "parameter" is at index 0 on the list, so it gets packed to `0x0300`
  --   * "storage" is at index 1, so it gets packed to `0x0301`
  --
  -- You can ask `octez-client` which code corresponds to a given
  -- instruction/type/constructor.
  --
  -- > octez-client convert data 'storage' from michelson to binary
  -- > 0x0301
  --
  -- Whenever new instructions/types/constructors are added to the protocol, we
  -- can regenerate this list using this script:
  --
  -- > ./scripts/get-micheline-exprs.sh
  --
  -- or find the full primitives list in the sources, see "prim_encoding"
  -- variable.
  -- https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml
  --
  -- Invariant: each constructor starts with `Prim_`
  = Prim_parameter | Prim_storage | Prim_code | Prim_False | Prim_Elt | Prim_Left
  | Prim_None | Prim_Pair | Prim_Right | Prim_Some | Prim_True | Prim_Unit
  | Prim_PACK | Prim_UNPACK | Prim_BLAKE2B | Prim_SHA256 | Prim_SHA512 | Prim_ABS
  | Prim_ADD | Prim_AMOUNT | Prim_AND | Prim_BALANCE | Prim_CAR | Prim_CDR
  | Prim_CHECK_SIGNATURE | Prim_COMPARE | Prim_CONCAT | Prim_CONS
  | Prim_CREATE_ACCOUNT | Prim_CREATE_CONTRACT | Prim_IMPLICIT_ACCOUNT | Prim_DIP
  | Prim_DROP | Prim_DUP | Prim_EDIV | Prim_EMPTY_MAP | Prim_EMPTY_SET | Prim_EQ
  | Prim_EXEC | Prim_FAILWITH | Prim_GE | Prim_GET | Prim_GT | Prim_HASH_KEY
  | Prim_IF | Prim_IF_CONS | Prim_IF_LEFT | Prim_IF_NONE | Prim_INT | Prim_LAMBDA
  | Prim_LE | Prim_LEFT | Prim_LOOP | Prim_LSL | Prim_LSR | Prim_LT | Prim_MAP
  | Prim_MEM | Prim_MUL | Prim_NEG | Prim_NEQ | Prim_NIL | Prim_NONE | Prim_NOT
  | Prim_NOW | Prim_OR | Prim_PAIR | Prim_PUSH | Prim_RIGHT | Prim_SIZE
  | Prim_SOME | Prim_SOURCE | Prim_SENDER | Prim_SELF | Prim_STEPS_TO_QUOTA
  | Prim_SUB | Prim_SWAP | Prim_TRANSFER_TOKENS | Prim_SET_DELEGATE | Prim_UNIT
  | Prim_UPDATE | Prim_XOR | Prim_ITER | Prim_LOOP_LEFT | Prim_ADDRESS
  | Prim_CONTRACT | Prim_ISNAT | Prim_CAST | Prim_RENAME | Prim_bool
  | Prim_contract | Prim_int | Prim_key | Prim_key_hash | Prim_lambda | Prim_list
  | Prim_map | Prim_big_map | Prim_nat | Prim_option | Prim_or | Prim_pair
  | Prim_set | Prim_signature | Prim_string | Prim_bytes | Prim_mutez
  | Prim_timestamp | Prim_unit | Prim_operation | Prim_address | Prim_SLICE
  | Prim_DIG | Prim_DUG | Prim_EMPTY_BIG_MAP | Prim_APPLY | Prim_chain_id
  | Prim_CHAIN_ID | Prim_LEVEL | Prim_SELF_ADDRESS | Prim_never | Prim_NEVER
  | Prim_UNPAIR | Prim_VOTING_POWER | Prim_TOTAL_VOTING_POWER | Prim_KECCAK
  | Prim_SHA3 | Prim_PAIRING_CHECK | Prim_bls12_381_g1 | Prim_bls12_381_g2
  | Prim_bls12_381_fr | Prim_sapling_state | Prim_sapling_transaction_deprecated
  | Prim_SAPLING_EMPTY_STATE | Prim_SAPLING_VERIFY_UPDATE | Prim_ticket
  | Prim_TICKET_DEPRECATED | Prim_READ_TICKET | Prim_SPLIT_TICKET
  | Prim_JOIN_TICKETS | Prim_GET_AND_UPDATE | Prim_chest | Prim_chest_key
  | Prim_OPEN_CHEST | Prim_VIEW | Prim_view | Prim_constant | Prim_SUB_MUTEZ
  | Prim_tx_rollup_l2_address | Prim_MIN_BLOCK_TIME | Prim_sapling_transaction
  | Prim_EMIT | Prim_Lambda_rec | Prim_LAMBDA_REC | Prim_TICKET | Prim_BYTES
  | Prim_NAT
  deriving stock (Eq, Ord, Enum, Bounded, Show, Read, Data, Lift)

type instance PrettyShow MichelinePrimitive = ()

instance Buildable MichelinePrimitive where
  build = build . T.drop 5 . show

instance Aeson.ToJSON MichelinePrimitive where
  toJSON = Aeson.String . pretty

instance Aeson.FromJSON MichelinePrimitive where
  parseJSON = Aeson.withText "MichelinePrimitive" \t ->
    either (fail . toString) pure $ readEither ("Prim_" <> t)

-- | Simple classification datakind for 'MichelinePrimitive'.
data MichelinePrimitiveTag
  = MPTKeyword  -- ^ Keywords, like @parameter@, @code@, @storage@, @view@
  | MPTInstr    -- ^ Instructions, e.g. @UNIT@, @DIP@, etc
  | MPTValue    -- ^ Value constructors like @Left@, @Lambda_rec@, etc
  | MPTType     -- ^ Types, like @unit@, @list@, etc
  | MPTRemoved  -- ^ Removed primitives: @CREATE_ACCOUNT@, @STEPS_TO_QUOTA@
  | MPTConstant -- ^ Keyword @constant@ for global constants
  deriving stock (Show, Eq, Enum, Bounded, Lift)

instance Buildable MichelinePrimitiveTag where
  build = \case
    MPTKeyword  -> "keyword"
    MPTInstr    -> "instruction"
    MPTValue    -> "value"
    MPTType     -> "type"
    MPTRemoved  -> "removed"
    MPTConstant -> "constant"

genSingletonsType ''MichelinePrimitiveTag

-- | Classify 'MichelinePrimitive'. This function uses heuristics to avoid
-- writing a giant case match, which means it's potentially partial. This should
-- be fine as it's used with TemplateHaskell, hence if some cases are not
-- covered, the build will fail.
primClassification :: MichelinePrimitive -> MichelinePrimitiveTag
primClassification cs
  | cs `elem` [Prim_CREATE_ACCOUNT, Prim_STEPS_TO_QUOTA] = MPTRemoved
  | cs `elem` [Prim_code, Prim_parameter, Prim_storage, Prim_view] = MPTKeyword
  | cs == Prim_constant = MPTConstant
  | all (isUpper || (== '_') || isDigit) str = MPTInstr
  | all (isLower || (== '_') || isDigit) str = MPTType
  | Just (c, rest) <- T.uncons str
  , all (isLower || (== '_') || isDigit) rest
  , isUpper c = MPTValue
  | otherwise = error $ "Unknown primitive class: " <> str
  where str = pretty cs :: Text