cleveland-0.1.1: lorentz-test/Test/Lorentz/Macro.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- | Tests for Lorentz macros.
--
-- They test logic of macros and type-level logic. Also they serve as
-- examples of using complex macros (e. g. parameterized with
-- type-level numbers)
module Test.Lorentz.Macro
( unit_dropX
, unit_cloneX
, unit_duupX
, unit_framedN
, unit_pair
, unit_replaceN
, unit_updateN
, unit_papair
, unit_ppaiir
, unit_cdar
, unit_cddr
, unit_caar
, unit_cadr
, unit_setCar
, unit_setCdr
, unit_mapCar
, unit_mapCdr
, unit_ifRight
, unit_ifSome
, unit_when_
, unit_unless_
, unit_whenSome
, unit_whenNone
, unit_mapInsert
, unit_mapInsertNew
, unit_deleteMap
, unit_setInsert
, unit_setInsertNew
, unit_setDelete
, unit_addressToEpAddress
, test_pushContractRef
, unit_dupTop2
, unit_fromOption
, unit_isSome
, unit_non
, unit_non'
, unit_isEmpty
, unit_nonZero
, test_execute
, test_applicate
) where
import Prelude hiding (drop, swap)
import Data.Map qualified as M
import Data.Set qualified as S
import Debug qualified (show)
import Test.HUnit (Assertion, assertBool, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import Lorentz qualified as L
import Lorentz
import Morley.Tezos.Address (parseAddress)
import Test.Cleveland
(call, expectFailedWith, originateSimple, scenarioEmulated, testScenarioOnEmulator)
----------------------------------------------------------------------------
-- Macros parameterized with type-level numbers
----------------------------------------------------------------------------
unit_dropX :: Assertion
unit_dropX = do
dropX @0 @?= dropX0
dropX @1 @?= dropX1
dropX @2 @?= dropX2
dropX @1 @?= dropX1'
where
dropX0 :: '[Bool] :-> '[]
dropX0 = dipN @0 drop
dropX1 :: [Bool, Integer] :-> '[Bool]
dropX1 = dipN @1 drop
dropX2 :: [Bool, Integer, Bool] :-> [Bool, Integer]
dropX2 = dipN @2 drop
dropX1' :: [Bool, Integer, Bool] :-> [Bool, Bool]
dropX1' = dipN @1 drop
unit_cloneX :: Assertion
unit_cloneX = do
cloneX @0 @?= cloneX0
cloneX @1 @?= cloneX1
cloneX @2 @?= cloneX2
where
cloneX0 :: [Bool, Integer] :-> [Bool, Integer]
cloneX0 = nop
cloneX1 :: [Bool, Integer] :-> [Bool, Bool, Integer]
cloneX1 = dup # nop
cloneX2 :: [Bool, Integer] :-> [Bool, Bool, Bool, Integer]
cloneX2 = dup # dup # nop
unit_duupX :: Assertion
unit_duupX = do
duupX @1 @?= duupX1
duupX @2 @?= duupX2
duupX @3 @?= duupX3
where
duupX1 :: [Bool, Integer, (), Bool] :-> [Bool, Bool, Integer, (), Bool]
duupX1 = dupN @1
duupX2 :: [Bool, Integer, (), Bool] :-> [Integer, Bool, Integer, (), Bool]
duupX2 = dupN @2
duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool]
duupX3 = dupN @3
unit_framedN :: Assertion
unit_framedN = do
framedN @0 nop @?= framedN0
framedN @1 drop @?= framedN1
framedN @2 cons @?= framedN2
framedN @3 (eq # L.and) # framedN @2 cons @?= framedNC
where
framedN0 :: '[Bool] :-> '[Bool]
framedN0 = framed @'[Bool] @'[] @'[] nop
framedN1 :: [Bool, (), Integer] :-> [(), Integer]
framedN1 = framed @[(), Integer] @'[Bool] @'[] drop
framedN2 :: [Bool, [Bool]] :-> '[[Bool]]
framedN2 = framed @'[] @[Bool, [Bool]] @'[[Bool]] cons
framedNC :: [Integer, Integer, Bool, [Bool], Integer] :-> [[Bool], Integer]
framedNC =
framed @[[Bool], Integer] @[Integer, Integer, Bool] @'[Bool] (eq # L.and) #
framed @'[Integer] @[Bool, [Bool]] @'[[Bool]] cons
unit_pair :: Assertion
unit_pair = do
carN @0 @?= carN0
carN @1 @?= carN1
carN @2 @?= carN2
cdrN @0 @?= cdrN0
cdrN @1 @?= cdrN1
cdrN @2 @?= cdrN2
where
carN0 :: '[(Bool, Integer), Integer] :-> '[Bool, Integer]
carN0 = pairGet @1
carN1 :: '[(Integer, (Bool, Integer))] :-> '[Bool]
carN1 = pairGet @3
carN2 :: [(Integer, (Integer, (Bool, Integer))), Integer] :-> [Bool, Integer]
carN2 = pairGet @5
cdrN0 :: '[(Integer, Bool)] :-> '[(Integer, Bool)]
cdrN0 = pairGet @0
cdrN1 :: [(Integer, Bool), Integer] :-> [Bool, Integer]
cdrN1 = pairGet @2
cdrN2 :: '[(Integer, (Integer, Bool))] :-> '[Bool]
cdrN2 = pairGet @4
unit_replaceN :: Assertion
unit_replaceN = do
replaceN @1 @?= swap # drop
replaceN @2 @?= replaceN2
replaceN @3 @?= replaceN3
where
replaceN2 :: [(), Integer, (), Bool] :-> [Integer, (), Bool]
replaceN2 = dipN @2 drop # dug @1
replaceN3 :: [Bool, Integer, (), Bool] :-> [Integer, (), Bool]
replaceN3 = dipN @3 drop # dug @2
unit_updateN :: Assertion
unit_updateN = do
updateN @1 cons @?= updateN1
updateN @2 cons @?= updateN2
updateN @3 cons @?= updateN3
where
updateN1 :: [Bool, [Bool], Integer, ()] :-> [[Bool], Integer, ()]
updateN1 = cons
updateN2 :: [Bool, Integer, [Bool], ()] :-> [Integer, [Bool], ()]
updateN2 = swap # dip cons
updateN3 :: [Bool, Integer, (), [Bool]] :-> [Integer, (), [Bool]]
updateN3 = dug @2 # dipN @2 cons
----------------------------------------------------------------------------
-- Other syntactic conveniences macros
----------------------------------------------------------------------------
unit_papair :: Assertion
unit_papair = do
papair @?= papair'
where
papair' :: '[Bool, Integer, ()] :-> '[((Bool, Integer), ())]
papair' = pair # pair
unit_ppaiir :: Assertion
unit_ppaiir = do
ppaiir @?= ppaiir'
where
ppaiir' :: '[Bool, Integer, ()] :-> '[(Bool, (Integer, ()))]
ppaiir' = dip pair # pair
unit_cdar :: Assertion
unit_cdar = do
cdar @?= cdar'
where
cdar' :: '[(Bool, (Integer, ()))] :-> '[Integer]
cdar' = cdr # car
unit_cddr :: Assertion
unit_cddr = do
cddr @?= cddr'
where
cddr' :: '[(Bool, (Integer, ()))] :-> '[()]
cddr' = cdr # cdr
unit_caar :: Assertion
unit_caar = do
caar @?= caar'
where
caar' :: '[((Bool, Integer), ())] :-> '[Bool]
caar' = car # car
unit_cadr :: Assertion
unit_cadr = do
cadr @?= cadr'
where
cadr' :: '[((Bool, Integer), ())] :-> '[Integer]
cadr' = car # cdr
unit_setCar :: Assertion
unit_setCar = do
setCar @?= setCar'
where
setCar' :: '[(Bool, Integer), ()] :-> '[((), Integer)]
setCar' = cdr # swap # pair
unit_setCdr :: Assertion
unit_setCdr = do
setCdr @?= setCdr'
where
setCdr' :: '[(Bool, Integer), ()] :-> '[(Bool, ())]
setCdr' = car # pair
unit_mapCar :: Assertion
unit_mapCar = do
mapCar L.not @?= mapCar'
where
mapCar' :: '[(Integer, Bool)] :-> '[(Integer, Bool)]
mapCar' = unpair # L.not # pair
unit_mapCdr :: Assertion
unit_mapCdr = do
mapCdr L.not @?= mapCdr'
where
mapCdr' :: '[(Bool, Integer)] :-> '[(Bool, Integer)]
mapCdr' = unpair # dip L.not # pair
unit_ifRight :: Assertion
unit_ifRight = do
ifRight L.not (dup # L.compare # eq0) @?= ifRight'
where
ifRight' :: '[Either Integer Bool] :-> '[Bool]
ifRight' = ifLeft (dup # L.compare # eq0) L.not
unit_ifSome
:: Assertion
unit_ifSome = do
ifSome (dup # L.compare # eq0) (push True) @?= ifSome'
where
ifSome' :: '[Maybe Integer] :-> '[Bool]
ifSome' = ifNone (push True) (dup # L.compare # eq0)
unit_when_ :: Assertion
unit_when_ = do
when_ (push 5 # add @Integer) @?= when_'
push 3 # push True # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 8
push 3 # push False # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 3
where
when_' :: '[Bool, Integer] :-> '[Integer]
when_' = if_ (push 5 # add @Integer) nop
unit_unless_ :: Assertion
unit_unless_ = do
unless_ (push 5 # add @Integer) @?= unless_'
push 3 # push True # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 3
push 3 # push False # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 8
where
unless_' :: '[Bool, Integer] :-> '[Integer]
unless_' = if_ nop (push 5 # add @Integer)
unit_whenSome :: Assertion
unit_whenSome = do
whenSome drop @?= whenSome'
where
whenSome' :: '[Maybe Integer] :-> '[]
whenSome' = ifSome drop nop
unit_whenNone :: Assertion
unit_whenNone = do
whenNone (push True) @?= whenNone'
where
whenNone' :: '[Maybe Bool] :-> '[Bool]
whenNone' = ifNone (push True) nop
unit_mapInsert :: Assertion
unit_mapInsert = do
mapInsert @?= mapInsert'
where
mapInsert' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool]
mapInsert' = dip L.some # update
unit_mapInsertNew :: Assertion
unit_mapInsertNew = do
mapInsertNew nop @?= mapInsertNew'
mapInsertNewValid -$? () @?= Right (M.singleton 5 True)
let mapInsertFail = mapInsertNewInvalid -$? ()
assertBool (Debug.show mapInsertFail <> " should fail") $ isLeft mapInsertFail
where
mapInsertNew' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool]
mapInsertNew' = dip L.some # dup # dip getAndUpdate # swap # ifNone drop (drop # nop # failWith)
mapInsertNewValid :: '[] :-> '[Map Integer Bool]
mapInsertNewValid = emptyMap # push True # push 5 # mapInsertNew nop
mapInsertNewInvalid :: '[] :-> '[Map Integer Bool]
mapInsertNewInvalid =
emptyMap #
push True # push 5 # mapInsertNew nop #
push True # push 5 # mapInsertNew nop
unit_deleteMap :: Assertion
unit_deleteMap = do
deleteMap @?= deleteMap'
where
deleteMap' :: '[Integer, Map Integer Bool] :-> '[Map Integer Bool]
deleteMap' = dip (none @Bool) # update
unit_setInsert :: Assertion
unit_setInsert = do
setInsert @?= setInsert'
where
setInsert' :: '[Integer, Set Integer] :-> '[Set Integer]
setInsert' = dip (push True) # update
unit_setInsertNew :: Assertion
unit_setInsertNew = do
setInsertNew nop @?= setInsertNew'
setInsertNewValid -$? () @?= Right (S.singleton 5 )
let setInsertFail = setInsertNewInvalid -$? ()
assertBool (Debug.show setInsertFail <> " should fail") $ isLeft setInsertFail
where
setInsertNew' :: '[Integer, Set Integer] :-> '[Set Integer]
setInsertNew' = dupTop2 # mem # if_ (nop # failWith) (dip (push True) # update)
setInsertNewValid :: '[] :-> '[Set Integer]
setInsertNewValid = emptySet # push 5 # setInsertNew nop
setInsertNewInvalid :: '[] :-> '[Set Integer]
setInsertNewInvalid = emptySet # push 5 # setInsertNew nop # push 5 # setInsertNew nop
unit_setDelete :: Assertion
unit_setDelete = do
setDelete @?= setDelete'
where
setDelete' :: '[Integer, Set Integer] :-> '[Set Integer]
setDelete' = dip (push False) # update
----------------------------------------------------------------------------
-- Morley macros
----------------------------------------------------------------------------
unit_addressToEpAddress :: Assertion
unit_addressToEpAddress = do
addressToEpAddress @?= addressToEpAddress'
where
addressToEpAddress' :: '[Address] :-> '[EpAddress]
addressToEpAddress' = forcedCoerce_
test_pushContractRef :: [TestTree]
test_pushContractRef =
[ testScenarioOnEmulator "Invalid contract ref calling fail" $ scenarioEmulated do
expectFailedWith True $ do
originatedContract <- originateSimple "target" def $ contract' ref
call originatedContract CallDefault 1
, testScenarioOnEmulator "Valid contract ref calling success" $ scenarioEmulated do
refContract <- originateSimple "caller" () refContract'
originatedContract <- originateSimple "target" def $ contract' $ toContractRef refContract
call originatedContract CallDefault 1
]
where
ref :: ContractRef Integer
ref = toContractRef $ TAddress $ unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD"
refContract' :: Contract Integer () ()
refContract' = defaultContract $ car # drop # unit # nil # pair
contract' :: ContractRef Integer -> Contract Integer () ()
contract' rf = defaultContract $
car #
pushContractRef @Integer (drop # push True # failWith) rf #
drop # drop #
unit # nil # pair
unit_dupTop2 :: Assertion
unit_dupTop2 = do
dupTop2 @?= dupTop2'
where
dupTop2' :: '[Bool, Integer] :-> '[Bool, Integer, Bool, Integer]
dupTop2' = dupN @2 # dupN @2
unit_fromOption :: Assertion
unit_fromOption = do
fromOption True @?= fromOption'
where
fromOption' :: '[Maybe Bool] :-> '[Bool]
fromOption' = ifSome nop (push True)
unit_isSome :: Assertion
unit_isSome = do
isSome @?= isSome'
where
isSome' :: '[Maybe Integer] :-> '[Bool]
isSome' = ifSome (drop # push True) (push False)
unit_non :: Assertion
unit_non = do
non 1 @?= non_
where
non_ :: '[Integer] :-> '[Maybe Integer]
non_ = non' (push 1 # eq)
unit_non' :: Assertion
unit_non' = do
non' (push 0 # eq) @?= non'_
where
non'_ :: '[Integer] :-> '[Maybe Integer]
non'_ = dup # framed (push 0 # eq :: Lambda Integer Bool) # if_ (drop # none) L.some
unit_isEmpty :: Assertion
unit_isEmpty = do
isEmpty @?= isEmpty'
where
isEmpty' :: '[[Integer]] :-> '[Bool]
isEmpty' = size # int # eq0
unit_nonZero :: Assertion
unit_nonZero = do
nonZero @?= nonZeroI
nonZero @?= nonZeroN
nonZero @?= nonZeroT
where
nonZeroI :: '[Integer] :-> '[Maybe Integer]
nonZeroI = dup # eq0 # if_ (drop # none) L.some
nonZeroN :: '[Natural] :-> '[Maybe Natural]
nonZeroN = dup # int # eq0 # if_ (drop # none) L.some
nonZeroT :: '[Ticket Natural] :-> '[Maybe (Ticket Natural)]
nonZeroT = readTicket # toField #rtAmount # int # eq0 # if_ (drop # none) L.some
----------------------------------------------------------------------------
-- Execute and applicate
----------------------------------------------------------------------------
test_execute :: [TestTree]
test_execute =
[ testCase "Two arguments lambda" $
let lam :: [Integer, Integer] :-> [(), Integer]
lam = add # unit
code = push 3 # push lam # execute # drop @()
in code -$? 5 @?= Right 8
, testCase "Zero arguments lambda" $
let lam :: '[] :-> '[Integer]
lam = push 5
code = drop # push lam # execute
in code -$? (0 :: Natural) @?= Right 5
]
test_applicate :: [TestTree]
test_applicate =
[ testCase "Simple partial application" $
let lam :: '[Integer, Integer] :-> '[Integer]
lam = add
code = dip (push lam) # applicate # push 1 # exec
in code -$? 5 @?= Right 6
]