TicketBalance.hs

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

module TestSuite.Cleveland.TicketBalance
  ( test_ticket_balance
  , test_all_ticket_balances
  ) where

import Fmt (Buildable, (+|), (|+))
import Lorentz hiding (assert)
import Test.Tasty (TestTree)

import Test.Cleveland

import Morley.Michelson.Parser (notes)

test_ticket_balance :: [TestTree]
test_ticket_balance =
  [ testScenario "getTicketBalance works" $ scenario do
      ticketer <- originate "ticketer" [] $ ticketerContract @Integer

      inBatch do
        transfer ticketer $ calling def (3, 1)
        transfer ticketer $ calling def (3, 2)
        transfer ticketer $ calling def (3, 3)
        pure ()

      getTicketBalance ticketer ticketer (3 :: Integer) @@== 6

  , testScenario "getTicketBalance works with annotated types" $ scenario do
      ticketer <- originate "ticketer" [] $ ticketerContract @TestTy

      inBatch do
        transfer ticketer $ calling def (TestLeft, 1)
        transfer ticketer $ calling def (TestRight ((), ()), 2)
        pure ()

      getTicketBalance ticketer ticketer TestLeft  @@== 1
      getTicketBalance ticketer ticketer (TestRight ((), ()))  @@== 2
  ]

data TestTy = TestLeft | TestRight ((), ())
  deriving stock Generic
  deriving anyclass IsoValue

instance HasAnnotation TestTy where
  getAnnotation _ =
    [notes|or :tyOr (unit %testLeft) (pair %testRight (unit %unit1 :ty1) (unit %unit2 :ty2))|]

test_all_ticket_balances :: TestTree
test_all_ticket_balances =
  testScenario "getAllTicketBalances works" $ scenario do
    ticketer <- originate "ticketer" [] $ ticketerContract @Integer

    inBatch do
      transfer ticketer $ calling def (1, 1)
      transfer ticketer $ calling def (2, 2)
      transfer ticketer $ calling def (3, 3)
      pure ()

    tickets <- getAllTicketBalances ticketer
    tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (1 :: Integer)) 1)
    tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (2 :: Integer)) 2)
    tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (3 :: Integer)) 3)

has
  :: (Eq (Element a), Buildable a, Buildable (Element a), MonadCleveland caps m, Container a)
  => a -> Element a -> m ()
has xs x = do
  assert (x `elem` xs) $ "Expected " +| xs |+ " to contain " +| x |+ ""

ticketerContract
  :: (NiceComparable t, NiceParameter t, NiceStorage t, HasAnnotation t)
  => Contract (t, Natural) [Ticket t] ()
ticketerContract = defaultContract
  $ unpair
  # unpair
  # ticket
  # assertSome [mt|Failed to create ticket|]
  # cons
  # nil
  # pair