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

module Main
  ( main
  ) where

import Control.Exception.Safe (throwString)
import Data.Aeson qualified as Aeson
import Data.Default (def)
import Data.Singletons (demote, fromSing)
import Data.Type.Equality (pattern Refl)
import Fmt (blockListF, build, nameF, pretty, (+|), (|+))
import GHC.IO.Encoding (setFileSystemEncoding)
import Options.Applicative qualified as Opt
import System.IO (utf8)

import Morley.Client
import Morley.Client.Parser
import Morley.Client.RPC
import Morley.Client.Util (extractAddressesFromValue)
import Morley.Micheline (fromExpression, toExpression, unStringEncode)
import Morley.Michelson.Runtime (prepareContract)
import Morley.Michelson.TypeCheck qualified as TC
import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Value (Value'(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Core (prettyTez)
import Morley.Util.Constrained
import Morley.Util.Exception (throwLeft)
import Morley.Util.Main (wrapMain)

mainImpl :: ClientArgsRaw -> MorleyClientM ()
mainImpl cmd =
  case cmd of
    Originate OriginateArgs{..} -> do
      contract <- liftIO $ prepareContract oaMbContractFile
      let originator = oaOriginateFrom
      originatorAA <- resolveAddressWithAlias originator
      (operationHash, contractAddr) <-
        originateUntypedContract OverwriteDuplicateAlias oaContractName originatorAA oaInitialBalance
          contract oaInitialStorage oaMbFee oaDelegate

      putTextLn "Contract was successfully deployed."
      putTextLn $ "Operation hash: " <> pretty operationHash
      putTextLn $ "Contract address: " <> formatAddress contractAddr

    Transfer TransferArgs{..} -> do
      sendAddress <- resolveAddressWithAlias taSender
      destAddress <- resolveAddress taDestination
      (operationHash, contractEvents) :: (OperationHash, [IntOpEvent]) <-
        withConstrained destAddress \case
          destContract@ContractAddress{} -> do
            contract <- getContract destContract
            SomeContract (Contract{} :: Contract cp st) <-
              throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
            let addrs = extractAddressesFromValue taParameter & mapMaybe \case
                  MkAddress x@ContractAddress{} -> Just x
                  _ -> Nothing
            tcOriginatedContracts <- getContractsParameterTypes addrs
            parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
              TC.typeVerifyParameter @cp tcOriginatedContracts taParameter
            transfer sendAddress destContract taAmount U.DefEpName parameter taMbFee
          destImplicit@ImplicitAddress {} -> case taParameter of
            U.ValueUnit -> transfer sendAddress destImplicit taAmount U.DefEpName VUnit Nothing
            _ -> throwString ("The transaction parameter must be 'Unit' "
              <> "when transferring to an implicit account")

      putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "."
      unless (null contractEvents) do
        putTextLn $ "Additionally, the following contract events were emitted:"
        putTextLn $ pretty $ blockListF contractEvents

    TransferTicket TransferTicketArgs{..} -> T.withUType ttaTicketType \(_ :: T.Notes t) -> do
      T.Dict <- throwLeft $ pure $ first (TC.UnsupportedTypeForScope (demote @t))
        $ T.checkScope @(T.ParameterScope t, T.Comparable t)
      sendAddress <- resolveAddressWithAlias ttaSender
      destAddress <- resolveAddress ttaDestination
      ticketer <- resolveAddress ttaTicketTicketer
      (operationHash, contractEvents) :: (OperationHash, [IntOpEvent]) <-
        withConstrained destAddress \case
          destContract@ContractAddress{} -> do
            contract <- getContract destContract
            SomeContract (Contract{} :: Contract cp st) <-
              throwLeft $ pure $ TC.typeCheckingWith def $ TC.typeCheckContract contract
            Constrained (_ :: T.SingT t') :: Constrained T.SingI T.SingT <- case T.sing @cp of
              T.STTicket x -> pure $ Constrained @T.SingI x
              x -> throwM $ TC.TcContractError @U.ExpandedOp
                ("Expected contract to accept tickets, but it had type " <> pretty (fromSing x))
                $ Just $ TC.UnexpectedType (one $ one $ "ticket 'a")
            Refl <- T.requireEq @t @t' $ throwM . TC.TypeEqError
            parameter <- throwLeft $ pure $ TC.typeCheckingWith def $ do
              TC.typeCheckValue @t' ttaTicketContents
            transferTicket @_ @t' sendAddress destContract ticketer parameter ttaTicketAmount
              U.DefEpName ttaMbFee
          destImplicit@ImplicitAddress{} -> do
            parameter <- throwLeft $ pure $ TC.typeCheckingWith def $
                  TC.typeCheckValue @t ttaTicketContents
            transferTicket sendAddress destImplicit ticketer parameter ttaTicketAmount
                  U.DefEpName ttaMbFee

      putTextLn $ "Tickets successfully sent.\nOperation hash " <> pretty operationHash <> "."
      unless (null contractEvents) do
        putTextLn $ "Additionally, the following contract events were emitted:"
        putTextLn $ pretty $ blockListF contractEvents

    GetBalance addrOrAlias -> do
      balance <- getBalance =<< resolveAddress addrOrAlias
      putTextLn $ prettyTez balance

    GetBlockHeader blockId -> do
      blockHeader <- getBlockHeader blockId
      putStrLn $ Aeson.encode blockHeader

    GetScriptSize GetScriptSizeArgs{..} -> do
      contract <- liftIO $ prepareContract (Just ssScriptFile)
      void . throwLeft . pure . TC.typeCheckingWith def $
        TC.typeCheckContractAndStorage contract ssStorage
      size <- computeUntypedContractSize contract ssStorage
      print size

    GetBlockOperations blockId -> do
      operationLists <- getBlockOperations blockId
      forM_ operationLists $ \operations -> do
        forM_ operations $ \BlockOperation {..} -> do
          putTextLn $ "Hash: " <> boHash
          putTextLn $ "Contents: "
          forM_ (orwmResponse <$> boContents) \case
            TransactionOpResp to -> putStrLn $ Aeson.encode to
            OtherOpResp -> putTextLn "Non-transaction operation"
          putTextLn ""
      putTextLn "——————————————————————————————————————————————————\n"
    TicketBalance owner' TicketBalanceArgs{..} -> do
      owner <- resolveAddress owner'
      bal <- getTicketBalance owner GetTicketBalance
        { gtbContent = toExpression tbaContent
        , gtbContentType = toExpression tbaContentType
        , gtbTicketer = tbaTicketer
        }
      print bal
    AllTicketBalances owner' -> do
      owner <- resolveAddress owner'
      bals <- getAllTicketBalances owner
      forM_ bals \GetAllTicketBalancesResponse{..} -> do
        content <- either throwM pure $ fromExpression @U.Value gatbrContent
        ty <- either throwM pure $ fromExpression @U.Ty gatbrContentType
        putTextLn $ pretty @Text $
          nameF "Ticketer" (build gatbrTicketer) |+ ", "
          +| nameF "content" (build content) |+ ", "
          +| nameF "type" (build ty) |+ ", "
          +| nameF "amount" (build $ unStringEncode gatbrAmount)

main :: IO ()
main = wrapMain $ do
  -- grepcake: the following line is needed to parse CL arguments (argv) in
  -- utf-8. It might be necessary to add the similar line to other
  -- executables. However, I've filed the issue for `with-utf8`
  -- (https://github.com/serokell/haskell-with-utf8/issues/8). If it gets fixed
  -- in upstream, this line should be safe to remove. In that case, FIXME.
  setFileSystemEncoding utf8

  disableAlphanetWarning
  ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo
  env <- mkMorleyClientEnv parsedConfig
  runMorleyClientM env (mainImpl cmd)