-- 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
  ]