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

-- | Parsing of Michelson types.

module Morley.Michelson.Parser.Type
  ( type_
  , field
  ) where

import Prelude hiding (note, some, try)

import Data.Default (Default)
import Fmt (pretty)
import Text.Megaparsec (choice, label)
import Text.Megaparsec.Char.Lexer qualified as L

import Morley.Michelson.Parser.Annotations
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Untyped

-- | This parses arbitrary type expressions.
--
-- Note that this includes parenthesized ones.
-- That is to say, @int@, @(int)@, @((int))@, etc will match with this parser and produce @TInt@.
type_ :: Parser Ty
type_ = snd <$> typeInner (pure noAnn)

field :: Parser (FieldAnn, Ty)
field = typeInner note

typeInner
  :: Parser FieldAnn -> Parser (FieldAnn, Ty)
typeInner fp = label "type" $ choice $ (parens field :) $ (\x -> x fp) <$>
  [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool
  , t_keyhash, t_timestamp, t_address
  , t_key, t_unit, t_never, t_signature, t_chain_id
  , t_bls12381fr, t_bls12381g1, t_bls12381g2
  , t_option, t_list, t_set
  , t_operation, t_contract, t_ticket, t_pair, t_or
  , t_lambda, t_map, t_big_map
  , t_chestKey, t_chest
  , t_saplingState, t_saplingTransaction, t_saplingTransactionDeprecated
  , t_txRollupL2Address
  ]

----------------------------------------------------------------------------
-- Non-comparable types
----------------------------------------------------------------------------

mkType :: T -> (a, TypeAnn) -> (a, Ty)
mkType t (a, ta) = (a, Ty t ta)


t_int :: (Default a) => Parser a -> Parser (a, Ty)
t_int fp = word "int" (mkType TInt) <*> fieldType fp

t_nat :: (Default a) => Parser a -> Parser (a, Ty)
t_nat fp = word "nat" (mkType TNat) <*> fieldType fp

t_string :: (Default a) => Parser a -> Parser (a, Ty)
t_string fp = word "string" (mkType TString) <*> fieldType fp

t_bytes :: (Default a) => Parser a -> Parser (a, Ty)
t_bytes fp = word "bytes" (mkType TBytes) <*> fieldType fp

t_mutez :: (Default a) => Parser a -> Parser (a, Ty)
t_mutez fp = word "mutez" (mkType TMutez) <*> fieldType fp

t_bool :: (Default a) => Parser a -> Parser (a, Ty)
t_bool fp = word "bool" (mkType TBool) <*> fieldType fp

t_keyhash :: (Default a) => Parser a -> Parser (a, Ty)
t_keyhash fp = word "key_hash" (mkType TKeyHash) <*> fieldType fp

t_timestamp :: (Default a) => Parser a -> Parser (a, Ty)
t_timestamp fp = word "timestamp" (mkType TTimestamp) <*> fieldType fp

t_address :: (Default a) => Parser a -> Parser (a, Ty)
t_address fp = word "address" (mkType TAddress) <*> fieldType fp

t_key :: (Default a) => Parser a -> Parser (a, Ty)
t_key fp = word "key" (mkType TKey) <*> fieldType fp

t_signature :: (Default a) => Parser a -> Parser (a, Ty)
t_signature fp = word "signature" (mkType TSignature) <*> fieldType fp

t_bls12381fr :: (Default a) => Parser a -> Parser (a, Ty)
t_bls12381fr fp = do
  symbol1 "bls12_381_fr"
  mkType TBls12381Fr <$> fieldType fp

t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Ty)
t_bls12381g1 fp = do
  symbol1 "bls12_381_g1"
  mkType TBls12381G1 <$> fieldType fp

t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Ty)
t_bls12381g2 fp = do
  symbol1 "bls12_381_g2"
  mkType TBls12381G2 <$> fieldType fp

t_chestKey :: (Default a) => Parser a -> Parser (a, Ty)
t_chestKey fp = do
  symbol1 "chest_key"
  mkType TChestKey <$> fieldType fp

t_chest :: (Default a) => Parser a -> Parser (a, Ty)
t_chest fp = word "chest" (mkType TChest) <*> fieldType fp

t_chain_id :: (Default a) => Parser a -> Parser (a, Ty)
t_chain_id fp = do
  symbol1 "chain_id"
  mkType TChainId <$> fieldType fp

t_operation :: (Default a) => Parser a -> Parser (a, Ty)
t_operation fp = word "operation" (mkType TOperation) <*> fieldType fp

t_contract :: (Default a) => Parser a -> Parser (a, Ty)
t_contract fp = do
  symbol1 "contract"
  (f, t) <- fieldType fp
  a <- type_
  return (f, Ty (TContract a) t)

t_ticket :: (Default a) => Parser a -> Parser (a, Ty)
t_ticket fp = do
  symbol1 "ticket"
  (f, t) <- fieldType fp
  a <- type_
  return (f, Ty (TTicket a) t)

-- | Parses a @unit@ type.
t_unit :: (Default a) => Parser a -> Parser (a, Ty)
t_unit fp = do
  symbol1 "unit"
  (f,t) <- fieldType fp
  return (f, Ty TUnit t)

t_never :: (Default a) => Parser a -> Parser (a, Ty)
t_never fp = do
  symbol1 "never" <|> symbol1 "⊥"
  (f,t) <- fieldType fp
  return (f, Ty TNever t)

t_pair :: (Default a) => Parser a -> Parser (a, Ty)
t_pair fp = do
  symbol1 "pair"
  (fieldAnn, typeAnn) <- fieldType fp
  fields <- many field
  tPair <- go fields
  pure $ (fieldAnn, Ty tPair typeAnn)
  where
    go :: [(FieldAnn, Ty)] -> Parser T
    go = \case
      [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."
      [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."
      [(fieldAnnL, typeL), (fieldAnnR, typeR)] ->
        pure $ TPair fieldAnnL fieldAnnR noAnn noAnn typeL typeR
      (fieldAnnL, typeL) : fields -> do
        rightCombedT <- go fields
        pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Ty rightCombedT noAnn)

t_or :: (Default a) => Parser a -> Parser (a, Ty)
t_or fp = do
  symbol1 "or"
  (f, t) <- fieldType fp
  (l, a) <- field
  (r, b) <- field
  return (f, Ty (TOr l r a b) t)

t_option :: (Default a) => Parser a -> Parser (a, Ty)
t_option fp = do
  symbol1 "option"
  (f, t) <- fieldType fp
  a <- snd <$> typeInner (pure noAnn)
  return (f, Ty (TOption a) t)

t_saplingState :: (Default a) => Parser a -> Parser (a, Ty)
t_saplingState fp = do
  symbol1 "sapling_state"
  (f,t) <- fieldType fp
  n <- lexeme L.decimal
  return (f, Ty (TSaplingState n) t)

t_saplingTransaction :: (Default a) => Parser a -> Parser (a, Ty)
t_saplingTransaction fp = do
  symbol1 "sapling_transaction"
  (f,t) <- fieldType fp
  n <- lexeme L.decimal
  return (f, Ty (TSaplingTransaction n) t)

t_saplingTransactionDeprecated :: Parser a -> Parser (a, Ty)
t_saplingTransactionDeprecated _ = do
  symbol1 "sapling_transaction_deprecated"
  fail "Use of deprecated type: sapling_transaction_deprecated"

t_lambda :: (Default a) => Parser a -> Parser (a, Ty)
t_lambda fp = do
  symbol1 "lambda"
  (f, t) <- fieldType fp
  a <- type_
  b <- type_
  return (f, Ty (TLambda a b) t)

-- Container types
t_list :: forall a. (Default a) => Parser a -> Parser (a, Ty)
t_list fp = do
  symbol1 "list"
  (f, t) <- fieldType fp
  a <- type_
  return (f, Ty (TList a) t)

t_set :: forall a. (Default a) => Parser a -> Parser (a, Ty)
t_set fp = do
  symbol1 "set"
  (f, t) <- fieldType fp
  a <- type_
  return (f, Ty (TSet a) t)

t_map_like
  :: (Default a)
  => Parser a -> Parser (Ty, Ty, a, TypeAnn)
t_map_like fp = do
  (f, t) <- fieldType fp
  a <- type_
  b <- type_
  return (a, b, f, t)

t_map :: (Default a) => Parser a -> Parser (a, Ty)
t_map fp = do
  symbol1 "map"
  (a, b, f, t) <- t_map_like fp
  return (f, Ty (TMap a b) t)

t_big_map :: (Default a) => Parser a -> Parser (a, Ty)
t_big_map fp = do
  symbol1 "big_map"
  (a, b, f, t) <- t_map_like fp
  return (f, Ty (TBigMap a b) t)

t_txRollupL2Address :: Default a => Parser a -> Parser (a, Ty)
t_txRollupL2Address fp = do
  symbol1 "tx_rollup_l2_address"
  _ <- fieldType fp
  fail "Transaction rollups are not supported"