Ext.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Test.Ext
  ( test_PRINT_and_TEST_ASSERT
  , test_STACKTYPE
  ) where

import Data.Default (def)
import Test.Hspec.Expectations (shouldSatisfy)
import Test.HUnit (Assertion, assertFailure)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Michelson.Interpret (InterpreterState(..), MorleyLogs(..), interpret)
import Michelson.Test (concatTestTrees, testTreesWithTypedContract)
import Michelson.Test.Dummy (dummyContractEnv)
import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheck, typeCheckExt, typeCheckList, getWTP)
import Michelson.Typed (pattern AsUType, epcPrimitive)
import qualified Michelson.Typed as T
import Michelson.Untyped
  (ExpandedExtInstr, ExtInstrAbstract(..), StackTypePattern(..), ParameterType(..),
  T(..), TyVar(..), Type(..), ann, noAnn)

import Test.Util.Contracts

test_PRINT_and_TEST_ASSERT :: IO [TestTree]
test_PRINT_and_TEST_ASSERT = concatTestTrees
  [ testTreesWithTypedContract (inContractsDir "testassert_square.mtz") $
    testAssertSquareImpl
  , testTreesWithTypedContract (inContractsDir "testassert_square2.mtz") $
    testAssertSquareImpl
  ]
  where
    testAssertSquareImpl c = pure
      [ testCase "TEST_ASSERT assertion passed" $ do
        runTest True c 100 100
        runTest True c 1 1
      , testCase "TEST_ASSERT assertion failed" $ do
        runTest False c 0 100
        runTest False c -1 -2
      ]

    runTest corr contract x y = do
      let x' = T.VInt x :: T.Value 'T.TInt
      let y' = T.VInt y :: T.Value 'T.TInt
      let area' = T.VInt $ x * y :: T.Value 'T.TInt
      let check (a, InterpreterState s _ _) =
            if corr then isRight a && s == MorleyLogs ["Area is " <> show area']
            else isLeft a && s == MorleyLogs ["Sides are " <> show x' <> " x " <> show y']
      interpret (T.cCode contract) epcPrimitive (T.VPair (x', y')) T.VUnit dummyContractEnv `shouldSatisfy` check

test_STACKTYPE :: [TestTree]
test_STACKTYPE =
  [ testCase "Correct test on [] pattern" $ runExtTest test1 True
  , testCase "Correct test on [a, b] pattern" $ runExtTest test2 True
  , testCase "Correct test on [a, b, ...] pattern" $ runExtTest test3 True
  , testCase "Correct test on [a, b, ...] pattern and stack [a, b]" $ runExtTest test4 True

  , testCase "Failed test on [] pattern and stack [a]" $ runExtTest test5 False
  , testCase "Failed test on [a, b] pattern and stack [a, b, c]" $ runExtTest test6 False
  , testCase "Failed test on [a, b] pattern and stack [a]" $ runExtTest test7 False
  , testCase "Failed test on [a, b, ...] pattern and stack [a]" $ runExtTest test8 False
  , testCase "Failed test on [a, b] pattern and stack [a, c]" $ runExtTest test9 False
  ]
  where
    p2 = StkCons (TyCon t1) (StkCons (TyCon t2) StkEmpty)
    p3 = StkCons (TyCon t1) (StkCons (TyCon t2) StkRest)

    test1 = (STACKTYPE StkEmpty, convertToHST [])
    test2 = (STACKTYPE p2, convertToHST [t1, t2])
    test3 = (STACKTYPE p3, convertToHST [t1, t2, t3])
    test4 = (STACKTYPE p3, convertToHST [t1, t2])

    test5 = (STACKTYPE StkEmpty, convertToHST [t1])
    test6 = (STACKTYPE p2, convertToHST [t1, t2, t3])
    test7 = (STACKTYPE p2, convertToHST [t1])
    test8 = (STACKTYPE p3, convertToHST [t1])
    test9 = (STACKTYPE p2, convertToHST [t1, t3])

    t1 = Type (TOption (Type TKey (ann "key"))) (ann "opt")
    t2 = Type (TPair (ann "f") (ann "s") (Type TUnit "x") (Type TSignature "s")) noAnn
    t3 = Type TInt (ann "tint")

    convertToHST :: [Type] -> SomeHST
    convertToHST [] = SomeHST SNil
    convertToHST (AsUType (nt :: T.Notes t1) : ts) =
      case convertToHST ts of
        SomeHST is -> case getWTP @t1 of
          Just T.Dict -> SomeHST ((nt, T.Dict, noAnn) ::& is)
          Nothing -> error "Type is not well typed"

    nh (ni, si) =
      runTypeCheck (ParameterType (Type TKey noAnn) noAnn) mempty $ usingReaderT def $ typeCheckExt typeCheckList ni si

    runExtTest :: (ExpandedExtInstr, SomeHST) -> Bool -> Assertion
    runExtTest (ui, SomeHST hst) correct = case (nh (ui, hst), correct) of
      (Right _, False) -> assertFailure $ "Test expected to fail but it passed"
      (Left e, True)   -> assertFailure $ "Test expected to pass but it failed with error: " <> show e
      _                -> pass