upgrading-daml-training/daml/Exercise1/Decimals.daml

{-# LANGUAGE ApplicativeDo #-}

module Exercise1.Decimals where

import Initial.Cash qualified as Old
import Initial.Scripts

import DA.Action
import DA.Assert
import DA.Foldable (forA_)
import Daml.Script

roundDown : Decimal -> Decimal
roundDown (d : Decimal) = (intToDecimal (truncate (d * 100.0))) / 100.0

template Position
  with
    issuer : Party
    owner : Party
    quantity : Decimal
    obs : [Party]
  where
    signatory [issuer, owner]
    observer obs
    ensure quantity > 0.0 && (roundDown quantity == quantity)

    choice Transfer : ContractId Position
      with
        newOwner : Party
      controller [owner, newOwner]
      do
        create this with 
          owner = newOwner
          obs = []

    choice Propose_Transfer : ContractId TransferProposal
      with
        newOwner : Party
      controller owner
      do
        create TransferProposal with 
          position = this
          newOwner

    choice Split : (ContractId  Position, [ContractId Position])
      with
        splitQuantities : [Decimal]
      controller owner
      do
        remCid <- create this with quantity = this.quantity -  sum splitQuantities
        splitCids <- forA splitQuantities (\splitQuantity -> create this with
            quantity = splitQuantity
          )
        return (remCid, splitCids)

    choice Merge : ContractId Position
      with
        otherCids : [ContractId Position]
      controller owner
      do
        quantities <- forA otherCids (\otherCid -> do
          other <- fetch otherCid
          other === this with 
            quantity = other.quantity
            obs = other.obs
          archive otherCid
          return other.quantity)
        create this with
          quantity = quantity + sum quantities

template TransferProposal
  with
    position : Position
    newOwner : Party
  where
    signatory (signatory position)
    observer newOwner::(observer position)

    choice Accept : ContractId Position
      controller newOwner
      do
        create position with
          owner = newOwner
          obs = []

    choice Cancel : ContractId Position
      controller position.owner
      do
        create position

-- In a separate package:

template UpgradeProposal
  with
    bank : Party
    counterparty : Party
  where
    signatory bank
    observer counterparty

    choice Accept_Upgrade : ContractId Upgrader
      controller counterparty
      do
        create Upgrader with ..

-- As part of the upgrade we have to decide what to do with the
-- extra decimal places.
-- In this example, we collect them up and issue a new position,
-- rounded to two decimals.
-- Any additional left-over is left non-upgraded.
template Upgrader
  with
      bank : Party
      counterparty : Party
    where
      signatory bank, counterparty

      nonconsuming choice Run_Upgrade : ()
        with
          positionCids : [ContractId Old.Position]
          tpCids : [ContractId Old.TransferProposal]
        controller bank
        do
          let
            splitPosition Old.Position{..} =
              let newQuantity = roundDown quantity
                  newPosition = Position with quantity = newQuantity; ..
                  rem = quantity - newQuantity
              in (newPosition, rem)
            cyclePosition p = do
              let (newPosition, rem) = splitPosition p
              create newPosition
              return rem
            cycleTp Old.TransferProposal{..} = do
              let (newPosition, rem) = splitPosition position
              create TransferProposal with position = newPosition; ..
              return rem

          posRems <- forA positionCids (\positionCid -> do
            position <- fetch positionCid
            position.owner === counterparty
            position.issuer === bank
            archive positionCid
            cyclePosition position
            )

          tpRems <- forA tpCids (\tpCid -> do
            tp <- fetch tpCid
            tp.position.owner === counterparty
            tp.position.issuer === bank
            archive tpCid
            cycleTp tp
            )

          let
            totalRem = sum posRems + sum tpRems
            roundedRems = roundDown totalRem
            remRem = totalRem - roundedRems


          when (roundedRems > 0.0) do
            void $ create Position with
              issuer = bank
              owner = counterparty
              quantity = roundedRems
              obs = []

          when (remRem > 0.0) do
            void $ create Old.Position with
                issuer = bank
                owner = counterparty
                quantity = remRem
                obs = []


while : (Action m) => m Bool -> m ()
while run = do
  continue <- run
  when continue (while run)

test_upgrade : Script ()
test_upgrade = do
  (tps@TestParties{..}, tus@TestUsers{..}) <- init_cash

  -- Bank proposes the upgrade
  submitUser uBank do
    createCmd UpgradeProposal with
      bank = pBank
      counterparty = pAlice
    createCmd UpgradeProposal with
      bank = pBank
      counterparty = pBob
    return ()

  -- Alice and Bob accept
  [(pa, _)] <- query @UpgradeProposal pAlice
  submitUser uAlice do exerciseCmd pa Accept_Upgrade
  [(pb, _)] <- query @UpgradeProposal pBob
  submitUser uBob do exerciseCmd pb Accept_Upgrade

  -- Run upgrade in batches of some reasonable size.
  let batchSize = 10
  upgraders <- query @Upgrader pBank
  forA_ upgraders (\(upgraderCid, upgrader) -> do
    while do
      poss <- take batchSize <$> queryFilter @Old.Position pBank
          (\pos -> pos.issuer == pBank && pos.owner == upgrader.counterparty)
      tps <- take (batchSize - length poss) <$> queryFilter @Old.TransferProposal pBank
          (\tp -> tp.position.issuer == pBank && tp.position.owner == upgrader.counterparty)
           
      if (length poss + length tps > 0)
        then do
          submitUser uBank do
            exerciseCmd upgraderCid Run_Upgrade with
              positionCids = map fst poss
              tpCids = map fst tps
          return True
        else return False
    return ()
    )