UParam.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Tests for Lorentz 'UParam'.
module Test.Lorentz.UParam
  ( test_Simple_contract
  , test_ADT_conversion
  , unit_unpackUParam
  ) where

import Data.Constraint (Dict(..))
import Fmt (Buildable, pretty)
import Test.HUnit (Assertion, assertBool, (@?=))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Lorentz ((/->))
import Lorentz qualified as L
import Lorentz.Base
import Lorentz.Run.Simple
import Lorentz.UParam
import Morley.Michelson.Interpret.Pack
import Morley.Michelson.Text
import Test.Cleveland.Instances ()

-- Test on simple contract
----------------------------------------------------------------------------

type Entries = ["add" ?: Natural, "id" ?: ()]

simpleCode :: '[UParam Entries, Integer] :-> '[Integer]
simpleCode = caseUParamT
  ( #add /-> L.add
  , #id /-> L.drop @()
  ) uparamFallbackFail

test_Simple_contract :: [TestTree]
test_Simple_contract =
  [ testCase "Passing parameter 1" $
      runSimpleCode 5 (mkUParam #add 3) @?= Right 8
  , testCase "Passing parameter 2" $
      runSimpleCode 5 (mkUParam #id ()) @?= Right 5
  , testCase "Passing illegal parameter" $
      assertBool "Expected failure" $
      isLeft $
      runSimpleCode 5 (UnsafeUParam ("Nyan", ""))
  ]
  where
    runSimpleCode initVal uparam = simpleCode -$? (uparam, initVal)

-- Test deconstruction
----------------------------------------------------------------------------

unit_unpackUParam :: Assertion
unit_unpackUParam = do
  unpk (mkUParam #add 3) @?=
    Right ("add", "3")
  unpk (mkUParam #id ()) @?=
    Right ("id", "()")
  unpk (UnsafeUParam ("gy", mempty)) @?=
    Left (NoSuchEntrypoint "gy")
  unpk (UnsafeUParam ("add", mempty)) @?=
    Left ArgumentUnpackFailed
  where
    unpk ::
      UParam Entries ->
      Either EntrypointLookupError (MText, String)
    unpk = fmap (second pretty) . unpackUParam @Buildable

-- Test ADT conversion
----------------------------------------------------------------------------

data Parameter1
  = MyEntrypoint1 Integer
  | MyEntrypoint2 ()
  deriving stock (Generic)

type ExpectedLinearization1 =
  [ "MyEntrypoint1" ?: Integer
  , "MyEntrypoint2" ?: ()
  ]

_checkLinearizedType
  :: Dict (UParamLinearized Parameter1 ~ ExpectedLinearization1)
_checkLinearizedType = Dict

test_ADT_conversion :: [TestTree]
test_ADT_conversion =
  [ testCase "Linearization 1.1" $
      uparamFromAdt (MyEntrypoint1 5)
        @?= UnsafeUParam ("MyEntrypoint1", packValue' (L.toVal @Integer 5))
  , testCase "Linearization 1.2" $
      uparamFromAdt (MyEntrypoint2 ())
        @?= UnsafeUParam ("MyEntrypoint2", packValue' (L.toVal ()))
  ]