-- 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 (MichelinePrimitive -> MichelinePrimitive -> Bool
(MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> Eq MichelinePrimitive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MichelinePrimitive -> MichelinePrimitive -> Bool
== :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
Eq, Eq MichelinePrimitive
Eq MichelinePrimitive
-> (MichelinePrimitive -> MichelinePrimitive -> Ordering)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> Ord MichelinePrimitive
MichelinePrimitive -> MichelinePrimitive -> Bool
MichelinePrimitive -> MichelinePrimitive -> Ordering
MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
compare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
$c< :: MichelinePrimitive -> MichelinePrimitive -> Bool
< :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c> :: MichelinePrimitive -> MichelinePrimitive -> Bool
> :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$cmax :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
max :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
$cmin :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
min :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
Ord, Int -> MichelinePrimitive
MichelinePrimitive -> Int
MichelinePrimitive -> [MichelinePrimitive]
MichelinePrimitive -> MichelinePrimitive
MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
MichelinePrimitive
-> MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
(MichelinePrimitive -> MichelinePrimitive)
-> (MichelinePrimitive -> MichelinePrimitive)
-> (Int -> MichelinePrimitive)
-> (MichelinePrimitive -> Int)
-> (MichelinePrimitive -> [MichelinePrimitive])
-> (MichelinePrimitive
    -> MichelinePrimitive -> [MichelinePrimitive])
-> (MichelinePrimitive
    -> MichelinePrimitive -> [MichelinePrimitive])
-> (MichelinePrimitive
    -> MichelinePrimitive
    -> MichelinePrimitive
    -> [MichelinePrimitive])
-> Enum MichelinePrimitive
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MichelinePrimitive -> MichelinePrimitive
succ :: MichelinePrimitive -> MichelinePrimitive
$cpred :: MichelinePrimitive -> MichelinePrimitive
pred :: MichelinePrimitive -> MichelinePrimitive
$ctoEnum :: Int -> MichelinePrimitive
toEnum :: Int -> MichelinePrimitive
$cfromEnum :: MichelinePrimitive -> Int
fromEnum :: MichelinePrimitive -> Int
$cenumFrom :: MichelinePrimitive -> [MichelinePrimitive]
enumFrom :: MichelinePrimitive -> [MichelinePrimitive]
$cenumFromThen :: MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
enumFromThen :: MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
$cenumFromTo :: MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
enumFromTo :: MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
$cenumFromThenTo :: MichelinePrimitive
-> MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
enumFromThenTo :: MichelinePrimitive
-> MichelinePrimitive -> MichelinePrimitive -> [MichelinePrimitive]
Enum, MichelinePrimitive
MichelinePrimitive
-> MichelinePrimitive -> Bounded MichelinePrimitive
forall a. a -> a -> Bounded a
$cminBound :: MichelinePrimitive
minBound :: MichelinePrimitive
$cmaxBound :: MichelinePrimitive
maxBound :: MichelinePrimitive
Bounded, Int -> MichelinePrimitive -> ShowS
[MichelinePrimitive] -> ShowS
MichelinePrimitive -> [Char]
(Int -> MichelinePrimitive -> ShowS)
-> (MichelinePrimitive -> [Char])
-> ([MichelinePrimitive] -> ShowS)
-> Show MichelinePrimitive
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MichelinePrimitive -> ShowS
showsPrec :: Int -> MichelinePrimitive -> ShowS
$cshow :: MichelinePrimitive -> [Char]
show :: MichelinePrimitive -> [Char]
$cshowList :: [MichelinePrimitive] -> ShowS
showList :: [MichelinePrimitive] -> ShowS
Show, ReadPrec [MichelinePrimitive]
ReadPrec MichelinePrimitive
Int -> ReadS MichelinePrimitive
ReadS [MichelinePrimitive]
(Int -> ReadS MichelinePrimitive)
-> ReadS [MichelinePrimitive]
-> ReadPrec MichelinePrimitive
-> ReadPrec [MichelinePrimitive]
-> Read MichelinePrimitive
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MichelinePrimitive
readsPrec :: Int -> ReadS MichelinePrimitive
$creadList :: ReadS [MichelinePrimitive]
readList :: ReadS [MichelinePrimitive]
$creadPrec :: ReadPrec MichelinePrimitive
readPrec :: ReadPrec MichelinePrimitive
$creadListPrec :: ReadPrec [MichelinePrimitive]
readListPrec :: ReadPrec [MichelinePrimitive]
Read, Typeable MichelinePrimitive
Typeable MichelinePrimitive
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> MichelinePrimitive
    -> c MichelinePrimitive)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c MichelinePrimitive)
-> (MichelinePrimitive -> Constr)
-> (MichelinePrimitive -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c MichelinePrimitive))
-> ((forall b. Data b => b -> b)
    -> MichelinePrimitive -> MichelinePrimitive)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> MichelinePrimitive -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> Data MichelinePrimitive
MichelinePrimitive -> Constr
MichelinePrimitive -> DataType
(forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
$ctoConstr :: MichelinePrimitive -> Constr
toConstr :: MichelinePrimitive -> Constr
$cdataTypeOf :: MichelinePrimitive -> DataType
dataTypeOf :: MichelinePrimitive -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
$cgmapT :: (forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
gmapT :: (forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
Data, (forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    MichelinePrimitive -> Code m MichelinePrimitive)
-> Lift MichelinePrimitive
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
$clift :: forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
lift :: forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
liftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
Lift)

type instance PrettyShow MichelinePrimitive = ()

instance Buildable MichelinePrimitive where
  build :: MichelinePrimitive -> Doc
build = Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc)
-> (MichelinePrimitive -> Text) -> MichelinePrimitive -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
5 (Text -> Text)
-> (MichelinePrimitive -> Text) -> MichelinePrimitive -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MichelinePrimitive -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show

instance Aeson.ToJSON MichelinePrimitive where
  toJSON :: MichelinePrimitive -> Value
toJSON = Text -> Value
Aeson.String (Text -> Value)
-> (MichelinePrimitive -> Text) -> MichelinePrimitive -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MichelinePrimitive -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty

instance Aeson.FromJSON MichelinePrimitive where
  parseJSON :: Value -> Parser MichelinePrimitive
parseJSON = [Char]
-> (Text -> Parser MichelinePrimitive)
-> Value
-> Parser MichelinePrimitive
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
"MichelinePrimitive" \Text
t ->
    (Text -> Parser MichelinePrimitive)
-> (MichelinePrimitive -> Parser MichelinePrimitive)
-> Either Text MichelinePrimitive
-> Parser MichelinePrimitive
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Parser MichelinePrimitive
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser MichelinePrimitive)
-> (Text -> [Char]) -> Text -> Parser MichelinePrimitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
forall a. ToString a => a -> [Char]
toString) MichelinePrimitive -> Parser MichelinePrimitive
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text MichelinePrimitive -> Parser MichelinePrimitive)
-> Either Text MichelinePrimitive -> Parser MichelinePrimitive
forall a b. (a -> b) -> a -> b
$ Text -> Either Text MichelinePrimitive
forall a b. (ToString a, Read b) => a -> Either Text b
readEither (Text
"Prim_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 (Int -> MichelinePrimitiveTag -> ShowS
[MichelinePrimitiveTag] -> ShowS
MichelinePrimitiveTag -> [Char]
(Int -> MichelinePrimitiveTag -> ShowS)
-> (MichelinePrimitiveTag -> [Char])
-> ([MichelinePrimitiveTag] -> ShowS)
-> Show MichelinePrimitiveTag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MichelinePrimitiveTag -> ShowS
showsPrec :: Int -> MichelinePrimitiveTag -> ShowS
$cshow :: MichelinePrimitiveTag -> [Char]
show :: MichelinePrimitiveTag -> [Char]
$cshowList :: [MichelinePrimitiveTag] -> ShowS
showList :: [MichelinePrimitiveTag] -> ShowS
Show, MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool
(MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool)
-> (MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool)
-> Eq MichelinePrimitiveTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool
== :: MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool
$c/= :: MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool
/= :: MichelinePrimitiveTag -> MichelinePrimitiveTag -> Bool
Eq, Int -> MichelinePrimitiveTag
MichelinePrimitiveTag -> Int
MichelinePrimitiveTag -> [MichelinePrimitiveTag]
MichelinePrimitiveTag -> MichelinePrimitiveTag
MichelinePrimitiveTag
-> MichelinePrimitiveTag -> [MichelinePrimitiveTag]
MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> [MichelinePrimitiveTag]
(MichelinePrimitiveTag -> MichelinePrimitiveTag)
-> (MichelinePrimitiveTag -> MichelinePrimitiveTag)
-> (Int -> MichelinePrimitiveTag)
-> (MichelinePrimitiveTag -> Int)
-> (MichelinePrimitiveTag -> [MichelinePrimitiveTag])
-> (MichelinePrimitiveTag
    -> MichelinePrimitiveTag -> [MichelinePrimitiveTag])
-> (MichelinePrimitiveTag
    -> MichelinePrimitiveTag -> [MichelinePrimitiveTag])
-> (MichelinePrimitiveTag
    -> MichelinePrimitiveTag
    -> MichelinePrimitiveTag
    -> [MichelinePrimitiveTag])
-> Enum MichelinePrimitiveTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MichelinePrimitiveTag -> MichelinePrimitiveTag
succ :: MichelinePrimitiveTag -> MichelinePrimitiveTag
$cpred :: MichelinePrimitiveTag -> MichelinePrimitiveTag
pred :: MichelinePrimitiveTag -> MichelinePrimitiveTag
$ctoEnum :: Int -> MichelinePrimitiveTag
toEnum :: Int -> MichelinePrimitiveTag
$cfromEnum :: MichelinePrimitiveTag -> Int
fromEnum :: MichelinePrimitiveTag -> Int
$cenumFrom :: MichelinePrimitiveTag -> [MichelinePrimitiveTag]
enumFrom :: MichelinePrimitiveTag -> [MichelinePrimitiveTag]
$cenumFromThen :: MichelinePrimitiveTag
-> MichelinePrimitiveTag -> [MichelinePrimitiveTag]
enumFromThen :: MichelinePrimitiveTag
-> MichelinePrimitiveTag -> [MichelinePrimitiveTag]
$cenumFromTo :: MichelinePrimitiveTag
-> MichelinePrimitiveTag -> [MichelinePrimitiveTag]
enumFromTo :: MichelinePrimitiveTag
-> MichelinePrimitiveTag -> [MichelinePrimitiveTag]
$cenumFromThenTo :: MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> [MichelinePrimitiveTag]
enumFromThenTo :: MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> MichelinePrimitiveTag
-> [MichelinePrimitiveTag]
Enum, MichelinePrimitiveTag
MichelinePrimitiveTag
-> MichelinePrimitiveTag -> Bounded MichelinePrimitiveTag
forall a. a -> a -> Bounded a
$cminBound :: MichelinePrimitiveTag
minBound :: MichelinePrimitiveTag
$cmaxBound :: MichelinePrimitiveTag
maxBound :: MichelinePrimitiveTag
Bounded, (forall (m :: * -> *). Quote m => MichelinePrimitiveTag -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    MichelinePrimitiveTag -> Code m MichelinePrimitiveTag)
-> Lift MichelinePrimitiveTag
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => MichelinePrimitiveTag -> m Exp
forall (m :: * -> *).
Quote m =>
MichelinePrimitiveTag -> Code m MichelinePrimitiveTag
$clift :: forall (m :: * -> *). Quote m => MichelinePrimitiveTag -> m Exp
lift :: forall (m :: * -> *). Quote m => MichelinePrimitiveTag -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitiveTag -> Code m MichelinePrimitiveTag
liftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitiveTag -> Code m MichelinePrimitiveTag
Lift)

instance Buildable MichelinePrimitiveTag where
  build :: MichelinePrimitiveTag -> Doc
build = \case
    MichelinePrimitiveTag
MPTKeyword  -> Doc
"keyword"
    MichelinePrimitiveTag
MPTInstr    -> Doc
"instruction"
    MichelinePrimitiveTag
MPTValue    -> Doc
"value"
    MichelinePrimitiveTag
MPTType     -> Doc
"type"
    MichelinePrimitiveTag
MPTRemoved  -> Doc
"removed"
    MichelinePrimitiveTag
MPTConstant -> Doc
"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 :: MichelinePrimitive -> MichelinePrimitiveTag
primClassification MichelinePrimitive
cs
  | Element [MichelinePrimitive]
MichelinePrimitive
cs Element [MichelinePrimitive] -> [MichelinePrimitive] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` [MichelinePrimitive
Prim_CREATE_ACCOUNT, MichelinePrimitive
Prim_STEPS_TO_QUOTA] = MichelinePrimitiveTag
MPTRemoved
  | Element [MichelinePrimitive]
MichelinePrimitive
cs Element [MichelinePrimitive] -> [MichelinePrimitive] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` [MichelinePrimitive
Prim_code, MichelinePrimitive
Prim_parameter, MichelinePrimitive
Prim_storage, MichelinePrimitive
Prim_view] = MichelinePrimitiveTag
MPTKeyword
  | MichelinePrimitive
cs MichelinePrimitive -> MichelinePrimitive -> Bool
forall a. Eq a => a -> a -> Bool
== MichelinePrimitive
Prim_constant = MichelinePrimitiveTag
MPTConstant
  | (Element Text -> Bool) -> Text -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Char -> Bool
isUpper (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| Char -> Bool
isDigit) Text
str = MichelinePrimitiveTag
MPTInstr
  | (Element Text -> Bool) -> Text -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Char -> Bool
isLower (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| Char -> Bool
isDigit) Text
str = MichelinePrimitiveTag
MPTType
  | Just (Char
c, Text
rest) <- Text -> Maybe (Char, Text)
T.uncons Text
str
  , (Element Text -> Bool) -> Text -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Char -> Bool
isLower (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a. Boolean a => a -> a -> a
|| Char -> Bool
isDigit) Text
rest
  , Char -> Bool
isUpper Char
c = MichelinePrimitiveTag
MPTValue
  | Bool
otherwise = Text -> MichelinePrimitiveTag
forall a. HasCallStack => Text -> a
error (Text -> MichelinePrimitiveTag) -> Text -> MichelinePrimitiveTag
forall a b. (a -> b) -> a -> b
$ Text
"Unknown primitive class: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
  where str :: Text
str = MichelinePrimitive -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty MichelinePrimitive
cs :: Text