module Test.Interpreter
  ( test_basic5
  , test_increment
  , test_fail
  , test_mutez_add_overflow
  , test_mutez_sub_overflow
  , test_basic1
  , test_lsl
  , test_lsr
  , test_FAILWITH
  , test_STEPS_TO_QUOTA
  , test_gas_exhaustion
  , test_add1_list
  , test_Sum_types
  , test_Product_types
  , test_split_bytes
  , test_split_string_simple
  , test_complex_strings
  , test_contract_instr_on_implicit
  , test_Entry_points_lookup
  , test_Entry_points_calling
  ) where

import qualified Data.Map as Map
import Data.Singletons (SingI)
import Fmt (pretty)
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)
import Test.HUnit (assertFailure)
import Test.QuickCheck (Property, label, (.&&.), (===))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import Test.Tasty.QuickCheck (testProperty)
import Util.Named ((.!))

import Michelson.Interpret
  (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps, interpret)
import Michelson.Test
import Michelson.Text
import Michelson.Typed (CT(..), CValue(..), IsoValue(..), T(..), epcPrimitive)
import qualified Michelson.Typed as T
import qualified Michelson.Untyped as U
import Tezos.Address
import Tezos.Core
import Tezos.Crypto

test_basic5 :: IO [TestTree]
test_basic5 =
  testTreesWithTypedContract "contracts/basic5.tz" $ \contract -> pure
  [ testCase "Basic test" $
      contractProp @() @[Integer] contract (validateStorageIs [13 :: Integer, 100])
        dummyContractEnv () [1]
  ]

test_increment :: IO [TestTree]
test_increment =
  testTreesWithTypedContract "contracts/increment.tz" $ \contract -> pure
  [ testCase "Basic test" $
      contractProp @() @Integer contract (validateStorageIs @Integer 24)
        dummyContractEnv () 23
  ]

test_fail :: IO [TestTree]
test_fail =
  testTreesWithTypedContract "contracts/tezos_examples/macros/fail.tz" $ \contract -> pure
  [ testCase "Fail test" $
      interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv
        `shouldSatisfy` (isLeft . fst)
  ]

test_mutez_add_overflow :: IO [TestTree]
test_mutez_add_overflow =
  testTreesWithTypedContract "contracts/mutez_add_overflow.tz" $ \contract -> pure
  [ testCase "Mutez add overflow test" $
      interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv
        `shouldSatisfy` (isLeft . fst)
  ]

test_mutez_sub_overflow :: IO [TestTree]
test_mutez_sub_overflow =
  testTreesWithTypedContract "contracts/mutez_sub_underflow.tz" $ \contract -> pure
  [ testCase "Mutez sub underflow test" $
      interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv
        `shouldSatisfy` (isLeft . fst)
  ]

test_basic1 :: IO [TestTree]
test_basic1 =
  testTreesWithTypedContract "contracts/basic1.tz" $ \contract -> pure
  [ testProperty "Random check" $ \input ->
      contractProp @_ @[Integer] contract (validateBasic1 input)
      dummyContractEnv () input
  ]

test_lsl :: IO [TestTree]
test_lsl =
  testTreesWithTypedContract "contracts/lsl.tz" $ \contract -> pure
  [ testCase "LSL shouldn't overflow test" $
      contractProp @Natural @Natural contract (validateStorageIs @Natural 20)
        dummyContractEnv 5 2
  , testCase "LSL should overflow test" $
      interpret contract epcPrimitive (toVal @Natural 5) (toVal @Natural 257) dummyContractEnv
        `shouldSatisfy` (isLeft . fst)
  ]

test_lsr :: IO [TestTree]
test_lsr =
  testTreesWithTypedContract "contracts/lsr.tz" $ \contract -> pure
  [ testCase "LSR shouldn't underflow test" $
      contractProp @Natural @Natural contract (validateStorageIs @Natural 3)
        dummyContractEnv 30 3
  , testCase "LSR should underflow test" $
      interpret contract epcPrimitive (toVal @Natural 1000) (toVal @Natural 257) dummyContractEnv
        `shouldSatisfy` (isLeft . fst)
  ]

test_FAILWITH :: IO [TestTree]
test_FAILWITH = concatTestTrees
  [ testTreesWithTypedContract "contracts/failwith_message.tz" $ \contract ->
    pure
    [ testCase "Failwith message test" $ do
        let msg = [mt|An error occurred.|] :: MText
        contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv
          msg ()
    ]
  , testTreesWithTypedContract "contracts/failwith_message2.tz" $ \contract ->
    pure
    [ testCase "Conditional failwith message test" $ do
        let msg = [mt|An error occurred.|]
        contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv
          (True, msg) ()

    , testCase "Conditional success test" $ do
        let param = (False, [mt|Err|] :: MText)
        contractProp contract validateSuccess dummyContractEnv param ()
    ]
  ]

test_STEPS_TO_QUOTA :: IO [TestTree]
test_STEPS_TO_QUOTA = concatTestTrees
  [ testTreesWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract ->
    pure
    [ testCase "Amount of steps should decrease (1)" $ do
      validateStepsToQuotaTest
        (interpret contract epcPrimitive T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 4
    ]
  , testTreesWithTypedContract "contracts/steps_to_quota_test2.tz" $ \contract ->
    pure
    [ testCase "Amount of steps should decrease (2)" $ do
      validateStepsToQuotaTest
        (interpret contract epcPrimitive T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 8
    ]
  ]

test_gas_exhaustion :: IO [TestTree]
test_gas_exhaustion =
  testTreesWithTypedContract "contracts/gas_exhaustion.tz" $ \contract -> pure
  [ testCase "Contract should fail due to gas exhaustion" $ do
      let dummyStr = toVal [mt|x|]
      case fst $ interpret contract epcPrimitive dummyStr dummyStr dummyContractEnv of
        Right _ -> assertFailure "expecting contract to fail"
        Left MichelsonGasExhaustion -> pass
        Left _ -> assertFailure "expecting another failure reason"
  ]

test_add1_list :: IO [TestTree]
test_add1_list =
  testTreesWithTypedContract "contracts/tezos_examples/attic/add1_list.tz" $ \contract ->
  let
    doValidate ::
      [Integer] -> ContractPropValidator (ToT [Integer]) Property
    doValidate param (res, _) =
      case res of
        Left failed -> failedProp $
          "add1_list unexpectedly failed: " <> pretty failed
        Right (fromVal . snd -> finalStorage) ->
          map succ param === finalStorage
  in pure
  [ testProperty "Random check" $ \param ->
      contractProp contract (doValidate param) dummyContractEnv param param
  ]

test_Sum_types :: IO [TestTree]
test_Sum_types = concatTestTrees
  [ testTreesWithTypedContract "contracts/union.mtz" $ \contract -> pure
    [ testGroup "union.mtz: union corresponds to Haskell types properly" $
        let caseTest param =
              contractProp contract validateSuccess dummyContractEnv param ()
        in
        [ testCase "Case 1" $ caseTest (Case1 3)
        , testCase "Case 2" $ caseTest (Case2 [mt|a|])
        , testCase "Case 3" $ caseTest (Case3 $ Just [mt|b|])
        , testCase "Case 4" $ caseTest (Case4 $ Left [mt|b|])
        , testCase "Case 5" $ caseTest (Case5 [[mt|q|]])
        ]
    ]
  , testTreesWithTypedContract "contracts/case.mtz" $ \contract -> pure
    [ testGroup "CASE instruction" $
        let caseTest param expectedStorage =
              contractProp contract (validateStorageIs @MText expectedStorage)
                dummyContractEnv param [mt||]
        in
        [ testCase "Case 1" $ caseTest (Case1 5) [mt|int|]
        , testCase "Case 2" $ caseTest (Case2 [mt|a|]) [mt|string|]
        , testCase "Case 3" $ caseTest (Case3 $ Just [mt|aa|]) [mt|aa|]
        , testCase "Case 4" $ caseTest (Case4 $ Right [mt|b|]) [mt|or string string|]
        , testCase "Case 5" $ caseTest (Case5 $ [[mt|a|], [mt|b|]]) [mt|ab|]
        ]
    ]
  , testTreesWithTypedContract "contracts/tag.mtz" $ \contract -> pure
    [ testCase "TAG instruction" $
        let expected = mconcat [[mt|unit|], [mt|o|], [mt|ab|], [mt|nat|], [mt|int|]]
        in contractProp contract (validateStorageIs expected) dummyContractEnv () [mt||]
    ]
  ]

test_Product_types :: IO [TestTree]
test_Product_types = concatTestTrees
  [ testTreesWithTypedContract "contracts/access.mtz" $ \contract -> pure
    [ testCase "ACCESS instruction" $
        contractProp @Tuple1 contract validateSuccess dummyContractEnv
          (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|]]) ()
    ]
  , testTreesWithTypedContract "contracts/set.mtz" $ \contract -> pure
    [ testCase "SET instruction" $
      let expected = (2, [mt|za|], Just [mt|wa|], Right [mt|ya|], [[mt|ab|]]) :: Tuple1
      in contractProp @_ @Tuple1 contract (validateStorageIs expected)
        dummyContractEnv () (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|], [mt|b|]])
    ]
  , testTreesWithTypedContract "contracts/construct.mtz" $ \contract -> pure
    [ testCase "CONSTRUCT instruction" $
      let expected = (1, [mt|a|], Just [mt|b|], Left [mt|q|], []) :: Tuple1
      in contractProp @_ @Tuple1 contract (validateStorageIs expected)
        dummyContractEnv () (0, [mt||], Nothing, Right [mt||], [])
    ]
  ]

test_split_bytes :: IO [TestTree]
test_split_bytes =
  testTreesWithTypedContract "contracts/tezos_examples/opcodes/split_bytes.tz" $ \contract ->
  pure
  [ testCase "splits given byte sequence into parts" $
      let expected = ["\11", "\12", "\13"] :: [ByteString]
      in contractProp contract (validateStorageIs expected) dummyContractEnv
         ("\11\12\13" :: ByteString) ([] :: [ByteString])
  ]

test_split_string_simple :: IO [TestTree]
test_split_string_simple =
  testTreesWithTypedContract "contracts/split_string_simple.tz" $ \contract ->
  pure
  [ testCase "applies SLICE instruction" $ do
      let
        oneTest :: Natural -> Natural -> MText -> Maybe MText -> Expectation
        oneTest o l str expected =
          contractProp contract (validateStorageIs expected) dummyContractEnv
          (o, l) (Just str)

      -- These values have been tested using alphanet.sh
      oneTest 0 0 [mt|aaa|] (Just [mt||])
      oneTest 2 0 [mt|aaa|] (Just [mt||])
      oneTest 3 0 [mt|aaa|] Nothing
      oneTest 0 5 [mt|aaa|] Nothing
      oneTest 1 2 [mt|abc|] (Just [mt|bc|])
      oneTest 1 1 [mt|abc|] (Just [mt|b|])
      oneTest 2 1 [mt|abc|] (Just [mt|c|])
      oneTest 2 2 [mt|abc|] Nothing
      oneTest 1 1 [mt|a""|] (Just [mt|"|])
      oneTest 1 2 [mt|a\n|] Nothing
  ]

test_complex_strings :: IO [TestTree]
test_complex_strings =
  testTreesWithTypedContract "contracts/complex_strings.tz" $ \contract ->
  pure
  [ testCase "ComplexString" $
      contractProp contract
      (validateStorageIs [mt|text: "aa" \\\n|])
      dummyContractEnv [mt|text: |] [mt||]
  ]

data Union1
  = Case1 Integer
  | Case2 MText
  | Case3 (Maybe MText)
  | Case4 (Either MText MText)
  | Case5 [MText]
  deriving stock (Generic)
  deriving anyclass (IsoValue)

type Tuple1 = (Integer, MText, Maybe MText, Either MText MText, [MText])

test_contract_instr_on_implicit :: IO [TestTree]
test_contract_instr_on_implicit =
  testTreesWithTypedContract "contracts/contract_instr_unit.tz" $ \contractGood ->
  testTreesWithTypedContract "contracts/contract_instr_nonunit.tz" $ \contractBad ->
  pure
  [ testCase "CONTRACT instruction succeeds on implicit accounts" $
      contractProp contractGood validateSuccess dummyContractEnv addr ()

  , testCase "CONTRACT instruction considers implicit accounts as unit-parametrized" $
      contractProp contractBad (validateMichelsonFailsWith [mt|No such contract|])
        dummyContractEnv addr ()
  ]
  where
    addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf"

-- TODO [TM-280] Move to separate module
test_Entry_points_lookup :: IO [TestTree]
test_Entry_points_lookup =
  testTreesWithTypedContract (dir <> "call1.mtz") $ \call1 ->
  testTreesWithTypedContract (dir <> "call2.mtz") $ \call2 ->
  testTreesWithTypedContract (dir <> "call3.mtz") $ \call3 ->
  testTreesWithTypedContract (dir <> "call4.mtz") $ \call4 ->
  testTreesWithTypedContract (dir <> "call5.mtz") $ \call5 ->
  testTreesWithTypedContract (dir <> "call6.mtz") $ \call6 ->
  testTreesWithTypedContract (dir <> "call7.mtz") $ \call7 ->
  pure
  [ testGroup "Calling contract without default entrypoint"
    [ testCase "Calling default entrypoint refers to the root" $
        checkProp call1 validateSuccess (addr "simple")
    , testCase "Calling some entrypoint refers this entrypoint" $
        checkProp call7 validateSuccess (addr "simple")
    ]
  , testGroup "Calling contract with default entrypoint"
    [ testCase "Calling default entrypoint works" $
        checkProp call2 validateSuccess (addr "def")
    ]
  , testGroup "Common failures"
    [ testCase "Fails on type mismatch" $
        checkProp call1 validateFailure (addr "def")
    , testCase "Fails on entrypoint not found" $
        checkProp call3 validateFailure (addr "simple")
    ]
  , testGroup "Referring entrypoints groups"
    [ testCase "Can refer entrypoint group" $
        checkProp call4 validateSuccess (addr "complex")
    , testCase "Works with annotations" $
        checkProp call5 validateSuccess (addr "complex")
    , testCase "Does not work on annotations mismatch in 'contract' type argument" $
        checkProp call6 validateFailure (addr "complex")
    ]
  ]
  where
    checkProp contract validator callee =
      contractProp @Address @()
        contract validator
        dummyContractEnv{ ceContracts = Map.fromList env }
        callee ()
    validateFailure = validateMichelsonFailsWith ()

    dir = "contracts/entrypoints/"
    contractSimpleTy =
      U.Type (U.TOr (U.ann "a") (U.ann "b") (U.Type U.Tint U.noAnn) (U.Type U.Tnat U.noAnn))
             U.noAnn
    contractComplexTy =
      U.Type (U.TOr (U.ann "s") (U.ann "t") (U.Type U.Tstring U.noAnn) contractSimpleTy)
             U.noAnn
    contractWithDefTy =
      U.Type (U.TOr (U.ann "a") (U.ann "default") (U.Type U.Tnat U.noAnn) (U.Type U.Tstring U.noAnn))
             U.noAnn
    addr = mkContractAddressRaw
    env =
      [ (mkContractHashRaw "simple", contractSimpleTy)
      , (mkContractHashRaw "complex", contractComplexTy)
      , (mkContractHashRaw "def", contractWithDefTy)
      ]

test_Entry_points_calling :: IO [TestTree]
test_Entry_points_calling =
  testTreesWithUntypedContract (dir <> "call1.mtz") $ \call1 ->
  testTreesWithUntypedContract (dir <> "contract1.mtz") $ \contract1 ->
  testTreesWithUntypedContract (dir <> "self1.mtz") $ \self1 ->
  pure
  -- TODO [TM-280]: Further use 'tOriginate' at least.
  -- Currently it's not possible, in untyped -> typed conversion we loose
  -- information about parameter annotations; to fix this, need to replace
  -- all 'T.Contract' with 'T.FullContract'.
  [ testCase "Calling some entrypoint in CONTRACT" $
      integrationalTestExpectation $ do
        callerRef <- originate call1 "caller" (T.untypeValue $ toVal ()) (toMutez 100)
        targetRef <- originate contract1 "target" (T.untypeValue $ toVal @Integer 0) (toMutez 100)

        tTransfer (#from .! genesisAddress) (#to .! callerRef) (toMutez 1)
          T.DefEpName (toVal targetRef)

        validate . Right $
          tExpectStorageConst targetRef (toVal @Integer 5)

  , testCase "Calling some entrypoint in SELF" $
      integrationalTestExpectation $ do
        contractRef <- originate self1 "self" (T.untypeValue $ toVal @Integer 0) (toMutez 100)

        tTransfer (#from .! genesisAddress) (#to .! contractRef) (toMutez 1)
          T.DefEpName (toVal $ Right @Integer ())

        validate . Right $
          tExpectStorageConst contractRef (toVal @Integer 5)
  ]
  where
    dir = "contracts/entrypoints/"

----------------------------------------------------------------------------

validateSuccess :: HasCallStack => ContractPropValidator st Expectation
validateSuccess (res, _) = res `shouldSatisfy` isRight

validateBasic1
  :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property
validateBasic1 input (Right (ops, res), _) =
    (fromVal res === [sum input + 12, 100])
    .&&.
    (label "returned no ops" $ null ops)
validateBasic1 _ (Left e, _) = failedProp $ show e

validateStepsToQuotaTest ::
  ContractReturn ('Tc 'CNat) -> RemainingSteps -> Expectation
validateStepsToQuotaTest res numOfSteps =
  case fst res of
    Right ([], T.VC (CvNat x)) ->
      (fromInteger . toInteger) x `shouldBe` ceMaxSteps dummyContractEnv - numOfSteps
    _ -> expectationFailure "unexpected contract result"

validateMichelsonFailsWith
  :: (T.IsoValue v, Typeable (ToT v), SingI (ToT v))
  => v -> ContractPropValidator st Expectation
validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v)