daml/daml-lf/tests/BasicTests.daml

-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0



module BasicTests where

import DA.Time
import DA.Date

data MyRec = MyRec { foo: Text }

data MyNestedRec = MyNestedRec { bar: Text;  nested: MyRec }

r : MyRec
r = MyRec { foo = "bar" }

r2 : MyNestedRec
r2 = MyNestedRec{ bar = "foo"; nested = r }

data XYZ = XYZ { x: Int; y: Int; z: Int }

xyz : Int -> Int -> Int -> XYZ
xyz x y z =
  XYZ with x = x; y = y+x; z = z+x

data XYZ2 = XYZ2 { a: XYZ; b: XYZ; c: XYZ }

testXyz : XYZ2
testXyz = XYZ2 with a = xyz 1 2 3; b = xyz 2 4 5; c = xyz 3 4 5

test_testXyzTest = scenario do
  pure testXyz
  pure testXyz

idToText : Int -> Text
idToText x = identity show x

double : Int -> Int
double x = 2 * x

myrecFoo : MyRec -> Text
myrecFoo x =  x.foo

four : () -> Int
four tok = 2 + (identity 2)

shadowTest : Int -> Int
shadowTest x = (\x -> x) $ 2 * x

test_letTest = scenario do
  let x = four ()
      y = double x
  assertS (x * y == 32)
  pure (x * y)

test_doubleLetTest = scenario do
  x <- test_letTest
  assertS (x == 32)
  pure x

hello : Text
hello = "hello world"

listTest : [Int]
listTest = [1, 2, 3]

listTest2 : [Int]
listTest2 = 1 :: 2 :: 3 :: []

foldrTest : () -> Text
foldrTest _tok =
  foldr (\x accum -> accum <> x) "" ["a", "b", "c"]

foldlTest : () -> Text
foldlTest _tok =
  foldl (\accum x -> accum <> x) "" ["a", "b", "c"]

upureTest: Update Text
upureTest =
  pure "hello"

tupeq : (Int, Int) -> (Int, Int) -> Bool
tupeq a b =
  a == b

tupeqtest : () -> Bool
tupeqtest _tok = tupeq (1, 1) (1, 2)

pt : [a] -> ([a], [a])
pt xs =
  let true x = True
  in
  partition true xs

-- def passWork (xs: List a) (x: a) : List a = xs -- cons x xs

passWork : [Int] -> [Int]
passWork xs =
  let work acc x = x :: acc
  in
  foldl work [] xs

consTest : [a] -> a -> [a]
consTest xs x = x :: xs

listEqTest : () -> Bool
listEqTest _tok =
  [1, 2, 3] == [3]

data Tree a = Leaf a | Node { left: Tree a, right: Tree a }

variantEqTest : () -> Bool
variantEqTest _tok =
  Some ((1, [1,2,3])) == Some ((1, [1,2,3]))

-- Decomposes a list into head and tail.
uncons : [a] -> Optional (a, [a])
uncons l =
  case l of
    [] -> None
    h :: t -> Some $ (h, t)

jtup : () -> Bool
jtup _tok =
  uncons [3,2,1] ==
    (Some (3, [2,1]))

template Simple
  with p: Party
  where
    agreement show p
    signatory p

    controller p can
      Hello : Text
        do pure "hello"

template SimpleMultiParty
  with
    p1: Party
    p2: Party
  where
    agreement show p1 <> show p2
    signatory p1, p2

    controller p1, p2 can
      HelloMultiParty : Text
        do pure "Hello multi-party"
    

template Composite
   with p1: Party
   where
     agreement show p1
     signatory p1

     controller p1 can
       First : Text
         do
           cid <- create Simple with p = p1
           cid2 <- exercise cid Hello
           pure "hello"


ucreate : Party -> Update (ContractId Simple)
ucreate p =
  create Simple with p=p

ucreateAndExercise : Party -> Update Text
ucreateAndExercise p = do
  cid <- create Simple with p=p
  exercise cid Hello

test_screateAndExercise = scenario do
  alice <- getParty "Alice"
  cid <- submit alice $ ucreate alice
  submit alice $ exercise cid Hello

test_screateAndExerciseComposit = scenario do
  alice <- getParty "Alice"
  cid <- submit alice $ create Composite with p1 = alice
  submit alice $ exercise cid First



variantMatch : Optional Int -> Int
variantMatch mbX =
  case mbX of
    Some x -> x
    None -> 0


listMatch : [Text] -> Text
listMatch l =
  case l of
    h ::_t -> h
    [] -> "<none>"

assertMsgS : Bool -> Text -> Scenario ()
assertMsgS b msg =
  if not b then abort msg else return ()

assertS : Bool -> Scenario ()
assertS b = assertMsgS b ""

assertMsg : Bool -> Text -> Update ()
assertMsg b msg  =
  if not b then abort msg else return ()

test_listMatchTest = scenario do
  assertMsgS (listMatch ["x"] == "x") "listMatch [x] == x"
  assertMsgS (listMatch [] == "<none>") "listMatch [] == <none>"

test_sgetTimeTest = scenario do
  getTime


-- Moves the scenario time forward to the specified time.
passTo (t: Time) = scenario do
  now: Time <- pass (days 0)
  assert {- TODO "passTo can only go forward in time"-} (now < t)
  pass (subTime t now)

ugetTime : Update Time
ugetTime = do
  t <- getTime
  pure t

test_ugetTimeTest = scenario do
  alice <- getParty "Alice"
  passToDate $ date 2017 Jun 16
  submit alice $ ugetTime


template TypeWithParameters
  with
    p: Party
    v: Optional Int
  where
    signatory p

    controller p can
      Hello2 : Text
        do pure "hello"

test_typeWithParameters = scenario do
  alice <- getParty "Alice"
  submit alice $ create TypeWithParameters with p = alice; v = Some 42



test_createAndFetch = scenario do
  alice <- getParty "alice"
  cid <- submit alice $ do
    cid <- create Simple with p=alice
    fetch cid -- relative fetch
    pure cid

  -- absolute fetch
  submit alice $ do
    x <- fetch cid -- absolute fetch
    create Simple with p=x.p

test_exponentiation = scenario do
  assertS (3 ^ 5 == 243)



template PayOut
  with
    receiver: Party
    giver: Party
  where
    signatory receiver
    signatory giver
    agreement
      (show giver) <> " must pay to " <>
      (show receiver) <> " the sum of five pounds."


template CallablePayout
  with
    giver: Party
    receiver: Party
  where
    signatory giver
    controller receiver can
      Call : ContractId PayOut
        do create PayOut with receiver; giver
      Transfer : ContractId CallablePayout
        with newReceiver: Party
        do create this with receiver = newReceiver



test_payoutTest = scenario do
  alice <- getParty "Alice"
  bob <- getParty "Bob"
  clara <- getParty "Clara"
  pa <- submit alice $ create CallablePayout with giver=alice;receiver=bob
-- 'Bob' should see all consequences
  submit bob $ exercise pa Transfer with newReceiver = clara

test_mustFails = scenario do
  alice <- getParty "Alice"
  bob <- getParty "Bob"
  passToDate $ date 2017 Jun 16
  cid <- submit alice $ ucreate alice
  submitMustFail bob $ exercise cid Hello

template TwoParties
  with p: Party
       p2: Party
  where
    agreement show p
    signatory p
    signatory p2

    controller p can
      Hello3 : Text
        do pure "hello"

    controller p2 can
      World : Text
        do pure "world"

template WithKey
  with p: Party
       k: Int
  where
    signatory p

    key (p, k): (Party, Int)
    maintainer key._1

    controller p can
      nonconsuming SumToK : Int
        with
          n : Int
        do pure (n + k)

template FetcherByKey
  with p: Party

  where
    signatory p

    controller p can
      nonconsuming Fetch : WithKey
        with
          n : Int
        do
          (_, c) <- fetchByKey @WithKey (p, n)
          pure c

template LookerUpByKey
  with p: Party
  where
    signatory p

    controller p can
      nonconsuming Lookup : Optional (ContractId WithKey)
        with
          n : Int
        do
          lookupByKey @WithKey (p, n)

template FailedFetchByKey
  with
    p : Party
  where
    signatory p
    choice FetchAfterLookup : (ContractId WithKey, WithKey)
      with
        n : Int
      controller p
      do let key = (p, n)
         None <- lookupByKey @WithKey key
         fetchByKey @WithKey key


test_failedAuths = scenario do
  alice <- getParty "alice"
  bob <- getParty "bob"
  submitMustFail alice $ (create TwoParties with p=alice; p2=bob)
-- this monster exists solely to test the nesting limit, in the absence of recursive types.
-- generated with
--
--    unlines ["data Nesting" ++ show (n - 1) ++ " = {x: Nesting" ++ show n ++ "}" | n <- [1..150]]

-- Tests for the dynamic computation of fetch actors
template Fetched
  with
    sig1 : Party
    sig2 : Party
    obs : Party
  where
    signatory sig1, sig2
    observer obs

template Fetcher
  with
    sig : Party
    obs : Party
    fetcher : Party
  where
    signatory sig
    controller fetcher can
      DoFetch : Fetched
        with cid : ContractId Fetched
        do fetch cid


template Forkable
  with
    party: Party
    parent: Optional (ContractId Forkable)
  where
    signatory party

    controller party can
      Fork: [ContractId Forkable]
        with n: Int
          do
            if (n == 0) then
               pure [self]
            else
              do
                c1 <- create Forkable with party = party, parent = Some self
                l1 <- exercise c1 Fork with n = n-1
                c2 <- create Forkable with party = party, parent = Some self
                l2 <- exercise c2 Fork with n = n-1
                pure (l1 ++ l2)


data Nesting0 = Nesting0 {x: Nesting1}
data Nesting1 = Nesting1 {x: Nesting2}
data Nesting2 = Nesting2 {x: Nesting3}
data Nesting3 = Nesting3 {x: Nesting4}
data Nesting4 = Nesting4 {x: Nesting5}
data Nesting5 = Nesting5 {x: Nesting6}
data Nesting6 = Nesting6 {x: Nesting7}
data Nesting7 = Nesting7 {x: Nesting8}
data Nesting8 = Nesting8 {x: Nesting9}
data Nesting9 = Nesting9 {x: Nesting10}
data Nesting10 = Nesting10 {x: Nesting11}
data Nesting11 = Nesting11 {x: Nesting12}
data Nesting12 = Nesting12 {x: Nesting13}
data Nesting13 = Nesting13 {x: Nesting14}
data Nesting14 = Nesting14 {x: Nesting15}
data Nesting15 = Nesting15 {x: Nesting16}
data Nesting16 = Nesting16 {x: Nesting17}
data Nesting17 = Nesting17 {x: Nesting18}
data Nesting18 = Nesting18 {x: Nesting19}
data Nesting19 = Nesting19 {x: Nesting20}
data Nesting20 = Nesting20 {x: Nesting21}
data Nesting21 = Nesting21 {x: Nesting22}
data Nesting22 = Nesting22 {x: Nesting23}
data Nesting23 = Nesting23 {x: Nesting24}
data Nesting24 = Nesting24 {x: Nesting25}
data Nesting25 = Nesting25 {x: Nesting26}
data Nesting26 = Nesting26 {x: Nesting27}
data Nesting27 = Nesting27 {x: Nesting28}
data Nesting28 = Nesting28 {x: Nesting29}
data Nesting29 = Nesting29 {x: Nesting30}
data Nesting30 = Nesting30 {x: Nesting31}
data Nesting31 = Nesting31 {x: Nesting32}
data Nesting32 = Nesting32 {x: Nesting33}
data Nesting33 = Nesting33 {x: Nesting34}
data Nesting34 = Nesting34 {x: Nesting35}
data Nesting35 = Nesting35 {x: Nesting36}
data Nesting36 = Nesting36 {x: Nesting37}
data Nesting37 = Nesting37 {x: Nesting38}
data Nesting38 = Nesting38 {x: Nesting39}
data Nesting39 = Nesting39 {x: Nesting40}
data Nesting40 = Nesting40 {x: Nesting41}
data Nesting41 = Nesting41 {x: Nesting42}
data Nesting42 = Nesting42 {x: Nesting43}
data Nesting43 = Nesting43 {x: Nesting44}
data Nesting44 = Nesting44 {x: Nesting45}
data Nesting45 = Nesting45 {x: Nesting46}
data Nesting46 = Nesting46 {x: Nesting47}
data Nesting47 = Nesting47 {x: Nesting48}
data Nesting48 = Nesting48 {x: Nesting49}
data Nesting49 = Nesting49 {x: Nesting50}
data Nesting50 = Nesting50 {x: Nesting51}
data Nesting51 = Nesting51 {x: Nesting52}
data Nesting52 = Nesting52 {x: Nesting53}
data Nesting53 = Nesting53 {x: Nesting54}
data Nesting54 = Nesting54 {x: Nesting55}
data Nesting55 = Nesting55 {x: Nesting56}
data Nesting56 = Nesting56 {x: Nesting57}
data Nesting57 = Nesting57 {x: Nesting58}
data Nesting58 = Nesting58 {x: Nesting59}
data Nesting59 = Nesting59 {x: Nesting60}
data Nesting60 = Nesting60 {x: Nesting61}
data Nesting61 = Nesting61 {x: Nesting62}
data Nesting62 = Nesting62 {x: Nesting63}
data Nesting63 = Nesting63 {x: Nesting64}
data Nesting64 = Nesting64 {x: Nesting65}
data Nesting65 = Nesting65 {x: Nesting66}
data Nesting66 = Nesting66 {x: Nesting67}
data Nesting67 = Nesting67 {x: Nesting68}
data Nesting68 = Nesting68 {x: Nesting69}
data Nesting69 = Nesting69 {x: Nesting70}
data Nesting70 = Nesting70 {x: Nesting71}
data Nesting71 = Nesting71 {x: Nesting72}
data Nesting72 = Nesting72 {x: Nesting73}
data Nesting73 = Nesting73 {x: Nesting74}
data Nesting74 = Nesting74 {x: Nesting75}
data Nesting75 = Nesting75 {x: Nesting76}
data Nesting76 = Nesting76 {x: Nesting77}
data Nesting77 = Nesting77 {x: Nesting78}
data Nesting78 = Nesting78 {x: Nesting79}
data Nesting79 = Nesting79 {x: Nesting80}
data Nesting80 = Nesting80 {x: Nesting81}
data Nesting81 = Nesting81 {x: Nesting82}
data Nesting82 = Nesting82 {x: Nesting83}
data Nesting83 = Nesting83 {x: Nesting84}
data Nesting84 = Nesting84 {x: Nesting85}
data Nesting85 = Nesting85 {x: Nesting86}
data Nesting86 = Nesting86 {x: Nesting87}
data Nesting87 = Nesting87 {x: Nesting88}
data Nesting88 = Nesting88 {x: Nesting89}
data Nesting89 = Nesting89 {x: Nesting90}
data Nesting90 = Nesting90 {x: Nesting91}
data Nesting91 = Nesting91 {x: Nesting92}
data Nesting92 = Nesting92 {x: Nesting93}
data Nesting93 = Nesting93 {x: Nesting94}
data Nesting94 = Nesting94 {x: Nesting95}
data Nesting95 = Nesting95 {x: Nesting96}
data Nesting96 = Nesting96 {x: Nesting97}
data Nesting97 = Nesting97 {x: Nesting98}
data Nesting98 = Nesting98 {x: Nesting99}
data Nesting99 = Nesting99 {x: Nesting100}
data Nesting100 = Nesting100 {x: Nesting101}
data Nesting101 = Nesting101 {x: Nesting102}
data Nesting102 = Nesting102 {x: Nesting103}
data Nesting103 = Nesting103 {x: Nesting104}
data Nesting104 = Nesting104 {x: Nesting105}
data Nesting105 = Nesting105 {x: Nesting106}
data Nesting106 = Nesting106 {x: Nesting107}
data Nesting107 = Nesting107 {x: Nesting108}
data Nesting108 = Nesting108 {x: Nesting109}
data Nesting109 = Nesting109 {x: Nesting110}
data Nesting110 = Nesting110 {x: Nesting111}
data Nesting111 = Nesting111 {x: Nesting112}
data Nesting112 = Nesting112 {x: Nesting113}
data Nesting113 = Nesting113 {x: Nesting114}
data Nesting114 = Nesting114 {x: Nesting115}
data Nesting115 = Nesting115 {x: Nesting116}
data Nesting116 = Nesting116 {x: Nesting117}
data Nesting117 = Nesting117 {x: Nesting118}
data Nesting118 = Nesting118 {x: Nesting119}
data Nesting119 = Nesting119 {x: Nesting120}
data Nesting120 = Nesting120 {x: Nesting121}
data Nesting121 = Nesting121 {x: Nesting122}
data Nesting122 = Nesting122 {x: Nesting123}
data Nesting123 = Nesting123 {x: Nesting124}
data Nesting124 = Nesting124 {x: Nesting125}
data Nesting125 = Nesting125 {x: Nesting126}
data Nesting126 = Nesting126 {x: Nesting127}
data Nesting127 = Nesting127 {x: Nesting128}
data Nesting128 = Nesting128 {x: Nesting129}
data Nesting129 = Nesting129 {x: Nesting130}
data Nesting130 = Nesting130 {x: Nesting131}
data Nesting131 = Nesting131 {x: Nesting132}
data Nesting132 = Nesting132 {x: Nesting133}
data Nesting133 = Nesting133 {x: Nesting134}
data Nesting134 = Nesting134 {x: Nesting135}
data Nesting135 = Nesting135 {x: Nesting136}
data Nesting136 = Nesting136 {x: Nesting137}
data Nesting137 = Nesting137 {x: Nesting138}
data Nesting138 = Nesting138 {x: Nesting139}
data Nesting139 = Nesting139 {x: Nesting140}
data Nesting140 = Nesting140 {x: Nesting141}
data Nesting141 = Nesting141 {x: Nesting142}
data Nesting142 = Nesting142 {x: Nesting143}
data Nesting143 = Nesting143 {x: Nesting144}
data Nesting144 = Nesting144 {x: Nesting145}
data Nesting145 = Nesting145 {x: Nesting146}
data Nesting146 = Nesting146 {x: Nesting147}
data Nesting147 = Nesting147 {x: Nesting148}
data Nesting148 = Nesting148 {x: Nesting149}
data Nesting149 = Nesting149 {x: Int}

template TimeGetter with
    p : Party
  where
    signatory p
    controller p can
      GetTime : Time
        do
         t <- getTime
         pure t
      FactorialOfThree: Int
        do
          pure $ product [1, 2, 3]

template ComputeContractKeyAfterEnsureClause with
    owner: Party
  where
    signatory owner
    ensure False
    key (error "Boom"): Party
    maintainer key

template ComputeContractKeyWhenExecutingCreate with
    owner: Party
  where
    signatory owner

    nonconsuming choice DontExecuteCreate: ()
      controller owner
      do
        let _ignore = create ComputeContractKeyAfterEnsureClause with owner
        pure ()

template NoMaintainer
  with
    sig: Party
  where
    signatory sig
    key sig : Party
    maintainer [] @Party

    nonconsuming choice Noop: ()
      controller sig
      do
        pure ()