-- | Tests for operation size evaluation.

module Test.OpSize
  ( test_Nesting
  , test_Numbers
  , test_Values
  , test_Types
  , test_Instructions
  ) where

import Prelude hiding (EQ)

import qualified Data.Text as T
import Fmt (pretty)
import Test.HUnit (Assertion, (@?=))
import Test.QuickCheck (Arbitrary(..))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Michelson.Macro
import Michelson.OpSize
import qualified Michelson.Parser as Parser
import Michelson.Typed
import Tezos.Address
import Tezos.Core
import Tezos.Crypto

import Test.Util.Parser
import Util.Test.Arbitrary

(?==) :: HasCallStack => Text -> Word -> Assertion
codeText ?== expectedCost = do
  parsed <- Parser.codeEntry `shouldParse` ("{" <> codeText <> "}")
  let code = expandList parsed
  expandedInstrsOpSize code @?= OpSize expectedCost

(?=) :: HasCallStack => Text -> Word -> TestTree
code ?= expectedCost = testCase (toString code) $ code ?== expectedCost

{- All particular numbers below are got using dump-op-size.py script -}

test_Nesting :: [TestTree]
test_Nesting =
  [ "" ?= 0
  , "{}" ?= 5
  , "{}; {}" ?= 10
  , mconcat (replicate 100 "{}; ") ?= 500
  , "{{}}" ?= 10
  ]

test_Numbers :: [TestTree]
test_Numbers =
  [ numTestCase 0 8
  , numTestCase 1 8
  , numTestCase 2 8
  , numTestCase 63 8
  , numTestCase 64 9
  , numTestCase 65 9
  , numTestCase 2048 9
  , numTestCase 20480 10
  , numTestCase (-1) 8
  , numTestCase (-63) 8
  , numTestCase (-64) 9
  ]
  where
  numTestCase (n :: Int) gas =
    testCase (show n) $ ("PUSH int " <> show n <> "; DROP") ?== gas

test_Values :: [TestTree]
test_Values =
  [ testGroup "int"
    [ valueTestCaseExt "small" "int" "5" 8
    , valueTestCaseExt "bigger" "int" "63" 8
    , valueTestCaseExt "big" "int" "64" 9
    ]
  , valueTestCase "nat" "5" 8
  , testGroup "string"
    [ stringTestCase 0 11
    , stringTestCase 1 12
    , stringTestCase 2 13
    , stringTestCase 7 18
    , stringTestCase 8 19
    ]
  , testGroup "bytes"
    [ bytesTestCase 0 11
    , bytesTestCase 1 12
    , bytesTestCase 2 13
    , bytesTestCase 7 18
    , bytesTestCase 8 19
    ]
  , valueTestCase "mutez" "5" 8
  , valueTestCase "bool" "True" 8
  , valueTestCase "key_hash" (stringLike $ pretty (gen @KeyHash)) 47
  , testGroup "timestamp"
    [ valueTestCaseExt "small" "timestamp" "5" 8
    , valueTestCaseExt "bigger" "timestamp" "123" 9
    , valueTestCaseExt "textual" "timestamp" (stringLike "2018-08-08 00:00:00Z") 31
    ]
  , testGroup "address"
    [ valueTestCaseExt "plain tz address" "address" (stringLike $ pretty (gen @Address)) 47
    , valueTestCaseExt "plain KT address" "address" (stringLike $ pretty (gen @Address)) 47
    , let addr = gen @Address
      in valueTestCaseExt "empty entrypoint" "address" (stringLike $ pretty addr <> "%") 48
    , let epAddr = EpAddress gen (EpNameUnsafe "a")
      in valueTestCaseExt "short entrypoint" "address" (stringLike $ pretty epAddr) 49
    , let epAddr = EpAddress gen (EpNameUnsafe . mconcat $ replicate 8 "a")
      in valueTestCaseExt "long entrypoint" "address" (stringLike $ pretty epAddr) 56
    ]
  -- ed25519 and secp256k1 keys have different size
  , valueTestCase "key" (stringLike $ pretty (PublicKeyEd25519 gen)) 65
  , valueTestCase "key" (stringLike $ pretty (PublicKeySecp256k1 gen)) 66
  , valueTestCase "unit" "Unit" 8
  , valueTestCase "signature" (stringLike $ pretty (gen @Signature)) 110
  , testGroup "chain_id"
    [ valueTestCase "chain_id" (stringLike $ pretty dummyChainId) 26
    , valueTestCase "chain_id" "0x00000000" 15
    ]
  , testGroup "option"
    [ valueTestCaseExt "none" "(option int)" "None" 10
    , valueTestCaseExt "some" "(option int)" "(Some 5)" 12
    ]
  , testGroup "list"
    [ valueTestCaseExt "Empty" "(list int)" "{}" 13
    , valueTestCaseExt "Length 1" "(list int)" "{1}" 15
    , valueTestCaseExt "Length 8" "(list int)" "{1;1;1;1;1;1;1;1}" 29
    ]
  , testGroup "set"
    [ valueTestCaseExt "Empty" "(set int)" "{}" 13
    , valueTestCaseExt "Length 1" "(set int)" "{1}" 15
    , valueTestCaseExt "Length 1" "(set int)" "{1;2;3;4;5;6;7;8}" 29
    ]
  , valueTestCaseExt "pair" "(pair int int)" "(Pair 1 2)" 16
  , valueTestCaseExt "or" "(or int int)" "(Left 1)" 14
  , testGroup "lambda"
    [ valueTestCaseExt "empty lambda" "(lambda int int)" "{}" 15
    , valueTestCaseExt "simple lambda" "(lambda int int)" "{DUP; DROP}" 19
    ]
  , testGroup "map"
    [ valueTestCaseExt "Empty" "(map int int)" "{}" 15
    , valueTestCaseExt "Length 1" "(map int int)" "{Elt 1 2}" 21
    , valueTestCaseExt "Length 1 (big key)" "(map int int)" "{Elt 100 2}" 22
    , let val = "{Elt 1 1; Elt 2 2; Elt 3 3; Elt 4 4; \
                \ Elt 5 5; Elt 6 6; Elt 7 7; Elt 8 8 }"
      in valueTestCaseExt "Length 8" "(map int int)" val 63
    ]
  ]
  where
    valueTestCaseExt name ty val gas =
      testCase name $
        ("PUSH " <> ty <> " " <> val <> "; DROP") ?== gas
    valueTestCase ty val gas =
      valueTestCaseExt (toString ty) ty val gas
    stringTestCase l gas =
      let name = "Length " <> show l
          val = stringLike $ T.replicate l "a"
      in valueTestCaseExt name "string" val gas
    bytesTestCase l gas =
      let name = "Length " <> show l
          val = "0x" <> T.replicate l "12"
      in valueTestCaseExt name "bytes" val gas

    stringLike x = "\"" <> x <> "\""
    gen :: Arbitrary a => a
    gen = runGen 12 arbitrary

test_Types :: [TestTree]
test_Types =
  [ typeTestCase "int" 8
  , typeTestCase "string" 8
  , typeTestCase "mutez" 8
  , typeTestCase "key_hash" 8
  , typeTestCase "address" 8
  , typeTestCase "signature" 8
  , typeTestCase "option int" 10
  , typeTestCase "list int" 10
  , typeTestCase "set int" 10
  , typeTestCase "contract int" 10
  , typeTestCase "pair int int" 12
  , typeTestCase "or int int" 12
  , typeTestCase "or (pair nat nat) (pair int nat)" 20
  , typeTestCase "lambda int unit" 12
  , typeTestCase "map int int" 12
  , typeTestCase "big_map int int" 12
  , typeTestCase "lambda operation int" 12

  , typeTestCase "pair int int" 12
  , typeTestCase "pair (int :a) int" 18
  , typeTestCase "pair (int %a) int" 18
  , typeTestCase "pair (int %a :a) int" 21
  , typeTestCase "pair (int %a) (int %a)" 24
  , typeTestCase "pair :a (int %a) (int %a)" 30
  , typeTestCase "pair :a int (int %a)" 24
  , typeTestCase "pair :a (int %a :a) (int %a)" 33
  ]
  where
  typeTestCase t gas =
    testCase (show t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas

test_Instructions :: [TestTree]
test_Instructions =
  [ customInstrTestCase "FAILWITH" 2
  , customInstrTestCase "FAIL" 9

  , instrTestCase "DUP" 4
  , instrTestCase "DUP @a" 10
  , instrTestCase "DUP; DROP" 6
  , instrTestCase "DUP; SWAP" 6
  , instrTestCase "DUP; SWAP; SWAP" 8
  , instrTestCase "PUSH int 0" 8
  , instrTestCase "PUSH @a int 0" 14
  , instrTestCase "PUSH @a (int :a) 0" 20
  , instrTestCase "SOME" 4
  , instrTestCase "SOME @a" 10
  , instrTestCase "SOME @a" 10
  , instrTestCase "NONE int" 6
  , instrTestCase "NONE (option int)" 8
  , instrTestCase "NONE :a @a (option :a int)" 23
  , instrTestCase "UNIT" 4
  , instrTestCase "DUP; SOME; IF_NONE {}{DROP}" 20
  , instrTestCase "DUP; DUP; PAIR" 8
  , instrTestCase "DUP; DUP; PAIR %a" 14
  , instrTestCase "DUP; DUP; PAIR %a %a" 17
  , instrTestCase "DUP; DUP; PAIR %a %a :a" 20
  , instrTestCase "DUP; DUP; PAIR %a %a :a @a" 23
    -- Further skipping some instructions since everything is trivial
  , instrTestCase "EMPTY_BIG_MAP :a @a (int :a) (unit :a)" 29
  , instrTestCase "PUSH (list int) {}; MAP {}" 20
  , instrTestCase "DIP {}" 9
  , instrTestCase "DIP 0 {}" 11
  , instrTestCase "DIP 1 {}" 11
  , instrTestCase "DROP 0" 6
  , instrTestCase "PACK" 4
  , instrTestCase "PUSH int 1; PUSH int 2; ADD" 16
  , instrTestCase "DUP; CONTRACT int" 8

  , instrTestCase "UNIT; PUSH mutez 5; NONE key_hash; \
                  \CREATE_CONTRACT \
                    \{ parameter unit; \
                    \  storage unit; \
                    \  code { CDR; NIL operation; PAIR } }" 44
  , instrTestCase "PUSH (or int nat) (Left 5); PUSH mutez 5; NONE key_hash; \
                  \CREATE_CONTRACT \
                    \{ parameter unit; \
                    \  storage (or int nat); \
                    \  code { DROP; PUSH (or int nat) (Right 2); NIL operation; PAIR } }" 70
  ]
  where
  customInstrTestCase instr gas =
    testCase (show instr) $ instr ?== gas
  instrTestCase instr gas =
    customInstrTestCase (instr <> "; FAILWITH") gas