ImplicitTickets.hs

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

module TestSuite.Cleveland.ImplicitTickets
  ( test_ticket_to_implicit
  , test_ticket_from_implicit
  ) where

import Lorentz hiding (assert)
import Test.Tasty (TestTree)

import Test.Cleveland

import Morley.Util.SizedList.Types

test_ticket_to_implicit :: TestTree
test_ticket_to_implicit = testScenario "sending tickets to implicit addresses works" $ scenario do
  ticketer <- originate "ticketer" () $ ticketerContract @Integer
  senderAddr ::< receiverAddr ::< Nil' <- newAddresses $ "sender" :< "receiver" :< Nil

  withSender senderAddr $ inBatch do
    transfer ticketer $ calling def (123, 3)
    transferTicket receiverAddr def ticketer (123 :: Integer) 1
    unsafeTransferTicket receiverAddr def ticketer (123 :: Integer) 1
    pure ()

  getTicketBalance senderAddr ticketer (123 :: Integer) @@== 1
  getTicketBalance receiverAddr ticketer (123 :: Integer) @@== 2

test_ticket_from_implicit :: TestTree
test_ticket_from_implicit = testScenario "sending tickets from implicit addresses works" $ scenario do
  ticketer <- originate "ticketer" () $ ticketerContract @Integer
  tbh <- originate "ticketBlackHole" () $ ticketBlackHole @Integer
  senderAddr <- newAddress "sender"

  withSender senderAddr $ inBatch do
    transfer ticketer $ calling def (123, 3)
    transferTicket tbh def ticketer 123 2
    unsafeTransferTicket tbh def ticketer (123 :: Integer) 1
    pure ()

  getTicketBalance senderAddr ticketer (123 :: Integer) @@== 0

ticketerContract
  :: forall t. (HasAnnotation t, NiceParameter t, NiceComparable t)
  => Contract (t, Natural) () ()
ticketerContract = defaultContract
  $ unpair
  # dip
    ( nil
    #  sender
    #  contract @(Ticket t)
    #  assertSome [mt|Failed to convert to contract|]
    #  push 0
    )
  # unpair
  # ticket
  # assertSome [mt|Failed to create ticket|]
  # transferTokens
  # cons
  # pair

ticketBlackHole
  :: forall t. (NiceParameter t, NiceComparable t, HasAnnotation t)
  => Contract (Ticket t) () ()
ticketBlackHole = defaultContract $ cdr # nil # pair