Meaningful error message in the given-when-then tests of the Shop example

I am using the given-when-then test structure which can be found in the Shop reference application, because in this way the test cases can be mapped directly to the standard formulation of user story acceptance criteria.

The only problem with this structure is that in the case of a failing test, it doesn’t return any meaningful error message, just an “Assertion failed” message from the assert function.

This is my attempt to improve it. It does the job, but maybe there is a more idiomatic / elegant solution.

I was thinking about assertMsg, but as far as i can see it, it cannot be used, because the message is created in the then_ function, and the assertMsg would be in the run function.

module Test where

import DA.Optional (isSome)
import Daml.Script

import Asset
import Shop

data Fixture = Fixture with
  issuer : Party
  producer : Party
  owner : Party
  vendor : Party
  user : Party
  shopId : ShopId
  itemId : ItemId
  iouId : IouId
  vendorId : VendorRelationshipId
  userId : UserRelationshipId 

data TestResult = Ok | Error Text
  deriving Eq

data Test a b = Test with
  given : Script a
  when : a -> Script b
  then_ : a -> b -> Script TestResult

run : Test a b -> Script ()
run t = do
  fixture <- t.given
  result <- t.when fixture
  check <- t.then_ fixture result
  case check of
    Error msg -> abort msg
    Ok -> return ()

given_a_shop : Script Fixture
given_a_shop = do
  issuer <- allocateParty "Issuer"
  producer <- allocateParty "Producer"
  owner <- allocateParty "Owner"
  vendor <- allocateParty "Vendor"
  user <- allocateParty "User"

  itemId <- submit producer do createCmd Item with producer; owner = producer; label = "Apple"; quantity = 1.0; unit = "kg"; observers = []
  itemId <- submit producer do exerciseCmd itemId TransferItem with newOwner = vendor
  iouId <- submit issuer do createCmd Iou with issuer; owner = issuer; amount = 3.0; currency = "USD"
  iouId <- submit issuer do exerciseCmd iouId TransferIou with newOwner = user

  shopId <- submit owner do createCmd Shop with owner; vendors = []; users = []; offerIds = []
  (shopId, inviteId) <- submit owner do exerciseCmd shopId InviteVendor with vendor
  vendorId <- submit vendor do exerciseCmd inviteId AcceptVendorInvite
  (shopId, inviteId) <- submit owner do exerciseCmd shopId InviteUser with user
  userId <- submit user do exerciseCmd inviteId AcceptUserInvite
  pure Fixture with ..

when_the_vendor_offers_an_item : Fixture -> Script (ShopId, OfferId)
when_the_vendor_offers_an_item f = do
  submit f.vendor do exerciseCmd f.vendorId OfferItem with shopId = f.shopId; itemId = f.itemId; price = 1.0; currency = "USD"

then_the_offer_is_added_to_the_shop : Fixture -> (ShopId, OfferId) -> Script TestResult
then_the_offer_is_added_to_the_shop f (shopId, offerId) = do
  shopOpt <- queryContractId f.owner shopId
  if let Some shop = shopOpt in offerId `elem` shop.offerIds
  then return Ok 
  else return $ Error "Error: Offer is not added to the shop"

then_the_offer_is_visible_to_the_user : Fixture -> (ShopId, OfferId) -> Script TestResult
then_the_offer_is_visible_to_the_user f (shopId, offerId) = do
  offerOpt <- queryContractId f.user offerId 
  if isSome offerOpt 
  then return Ok
  else return $ Error "Error: Offer is not visible to the user"

when_an_item_is_bought : Fixture -> Script (ShopId, ItemId, IouId)
when_an_item_is_bought f = do
  let Fixture{..} = f
  (shopId, offerId) <- submit vendor do exerciseCmd vendorId OfferItem with price = 3.0; currency = "USD"; ..
  submit user do exerciseCmd userId BuyItem with ..

then_the_item_and_iou_exchange_hands : Fixture -> (ShopId, ItemId, IouId) -> Script TestResult
then_the_item_and_iou_exchange_hands f (shopId, itemId, iouId) = do
  itemOpt <- queryContractId f.user itemId
  iouOpt <- queryContractId f.vendor iouId 
  if let Some item = itemOpt in item.owner == f.user && let Some iou = iouOpt in iou.owner == f.vendor
  then return Ok
  else return $ Error "Error: Item and iou don't exchange hands"

gwt = script do
  let offer_added = Test with
        given = given_a_shop
        when = when_the_vendor_offers_an_item
        then_ = then_the_offer_is_added_to_the_shop
  let offer_user_visible = offer_added with
        then_ = then_the_offer_is_visible_to_the_user
  let asset_exchange = Test with
        given = given_a_shop
        when = when_an_item_is_bought
        then_ = then_the_item_and_iou_exchange_hands
  run offer_added
  run offer_user_visible
  run asset_exchange

Hi @gyorgybalazsi

Is there anything specific you’d like feedback on?

Thanks, @nemanja I just put my thinking out there, to see if maybe somebody else also finds it useful.