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

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}

module Test.Parser
  ( test_parse_contracts
  , test_value
  , test_string_literal
  , test_annotation
  , test_IF
  , test_MAP
  , test_PAIR
  , test_UNPAIR
  , test_pair_type
  , test_tuple_type
  , test_or_type
  , test_lambda_type
  , test_list_type
  , test_set_type
  , test_Pair_constructor
  , test_printComment
  , test_parser_exception
  , test_letType
  , test_block_comment
  , test_UNPAPAIR
  , test_mandatory_spaces
  ) where

import Data.List.NonEmpty qualified as NE
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Test.Hspec (shouldBe, shouldSatisfy)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)
import Text.Megaparsec (parse)
import Text.Megaparsec.Error
  (ErrorFancy(ErrorCustom), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors)

import Morley.Michelson.ErrorPos (srcPos)
import Morley.Michelson.Macro as Mo
import Morley.Michelson.Parser as P
import Morley.Michelson.Parser.Annotations as PA
import Morley.Michelson.Parser.Lexer as PL
import Morley.Michelson.Parser.Types (LetEnv, Parser')
import Morley.Michelson.Untyped as Mo
import Morley.Util.Positive
import Test.Cleveland.Instances ()
import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts)

----------------------------------------------------------------------------
-- Contracts
----------------------------------------------------------------------------

test_parse_contracts :: [TestTree]
test_parse_contracts =
  [ testCase "well-typed and ill-typed contracts are parsable" $ do
      files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts
      mapM_ (checkFile True) files
  , testCase "bad contracts are unparsable" $ do
      files <- getUnparsableContracts
      mapM_ (checkFile False) files
  ]

----------------------------------------------------------------------------
-- Values
----------------------------------------------------------------------------

test_value :: [TestTree]
test_value = testSatisfyingCases P.value
  [ ( "{}"
    , Right Mo.ValueNil
    )
  , ( "{PUSH int 5;}"
    , Right . ValueLambda $ NE.fromList
        [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]
    )
  , ( "{1; 2}"
    , Right . Mo.ValueSeq $ NE.fromList
        [Mo.ValueInt 1, Mo.ValueInt 2]
    )
  , ( "{Elt 1 2; Elt 3 4}"
    , Right . Mo.ValueMap $ NE.fromList
        [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]
    )
  , ( "{DIP DROP;}"
    , Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))
    )
  , ( "{{ }; {}; {PUSH int 5; DROP}}"
    , Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1) :|
              [ Mo.Seq [] (srcPos 0 6)
              , Mo.Seq [ Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)
                       , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)
              ]))
    )
  , ( "{{}; {}; {5}}"
    , Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))
    )
  ] ++

  testSatisfyingCasesPredicate P.value
    [ ("{DIP DROP;somecontent}", isLeft)
    , ("{{}; {5}; {Push int 5}}", isLeft)
    ]

test_string_literal :: [TestTree]
test_string_literal = testSatisfyingCasesPredicate P.stringLiteral
  [ ("\"\"", isRight)
  , ("\" \\n  \"", isRight)
  , ("\"abacaba \\t \n\n\r a\"", isLeft)
  , ("\"abacaba \\t \\n\\n\\r", isLeft)
  ]

----------------------------------------------------------------------------
-- Annotations
----------------------------------------------------------------------------

test_annotation :: [TestTree]
test_annotation = testSatisfyingCasesPredicate PA.noteV
  [ ("@", isRight)
  , ("@_", isRight)
  , ("@a.", isRight)
  , ("@7a", isRight)
  , ("@.a", isLeft)
  , ("@@@", isLeft)
  , ("@a b", isLeft)
  , ("@a\\", isLeft)
  -- TODO [#48] these are special annotations and should not always be accepted
  , ("@%", isRight)
  , ("@%%", isRight)
  ]

----------------------------------------------------------------------------
-- Instructions
----------------------------------------------------------------------------

test_IF :: [TestTree]
test_IF = testSatisfyingCases P.codeEntry
  [ ( "{IF {} {};}"
    , Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]
    )
  , ( "{IFEQ {} {};}"
    , Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]
    )
  , ( "{IFCMPEQ {} {};}"
    , Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]
    )
  ]

test_MAP :: [TestTree]
test_MAP = testSatisfyingCases P.codeEntry
  [ ( "{MAP {};}"
    , Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]
    )
  , ( "{MAP_CAR {};}"
    , Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]
    )
  ]

test_PAIR :: [TestTree]
test_PAIR = testSatisfyingCases P.codeEntry
  [ ( "{PAIR;}"
    , Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]
    )
  , ( "{PAIR %a;}"
    , Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]
    )
  , ( "{PAIR %0;}"
    , Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]
    )
  , ( "{PAPAIR;}"
    , Right
        [flip Mac (srcPos 0 1) $
          PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))
            noAnn noAnn
        ]
    )
  ]

test_UNPAPAIR :: [TestTree]
test_UNPAPAIR = testSatisfyingCases P.codeEntry
  [ ( "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}"
    , Right [unpapair]
    )
  , ( "{UNPAPAIR @a %b @c %d %e @f;}"
    , Right [unpapair]
    )
  , ( "{UNPAPAIR;}"
    , Right [unpapair]
    )
  ]
  where
    unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1)

test_UNPAIR :: [TestTree]
test_UNPAIR = testSatisfyingCases P.codeEntry
  [ ( "{UNPAIR;}"
    , Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR %a;}"
    , Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR @a;}"
    , Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR @a %b;}"
    , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR %b @a;}"
    , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR @a @b;}"
    , Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR %c %d;}"
    , Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]
    )
  , ( "{UNPAIR @a @b %c;}"
    , Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]
    )
  , ( "{UNPAIR @a @b %c %d;}"
    , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]
    )
  , ( "{UNPAIR %c %d @a;}"
    , Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]
    )
  , ( "{UNPAIR %c %d @a @b;}"
    , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]
    )
  ] ++

  [ -- should fail because the two field anns are not "grouped" together.
    handleTrivialError
      "{UNPAIR %c @a @b %d;}"
      P.codeEntry
      (Tokens ('%' :| ""))
  , -- should fail because the two var anns are not "grouped" together.
    handleTrivialError
      "{UNPAIR @a %c %d @b;}"
      P.codeEntry
      (Tokens ('@' :| ""))
  ]

----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------

test_pair_type :: [TestTree]
test_pair_type =
  [ testGroup "simple pair type" $
    testSatisfyingCases P.type_
      [ ("pair unit unit", Right unitPair)
      , ("(unit, unit)", Right unitPair)
      ]
    ++
    testSatisfyingCasesPredicate P.type_
      [ ("(key, (int, (string, bool)))", isRight)
      , ("(signature, chain_id, string, bool)", isRight)
      ]
  , testGroup "right-combed pair type" $
      testSatisfyingCases P.type_
        [ ("pair unit int string", Right rightCombPair)
        , ("(unit, int, string)", Right rightCombPair)
        ]
  , testGroup "right-combed pair type with annotations" $
      testSatisfyingCases P.type_
        [ ( "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)"
          , Right rightCombPairWithAnns
          )
        , ( "(unit :t1 %x, int :t2 %y, string %z :t3) :t"
          , Right rightCombPairWithAnns
          )
        ]
  ]
  where
    unitPair :: Mo.Ty
    unitPair =
      Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn

    rightCombPair :: Mo.Ty
    rightCombPair =
      Mo.Ty
        (Mo.TPair noAnn noAnn noAnn noAnn
          (Mo.Ty Mo.TUnit noAnn)
          (Mo.Ty
            (Mo.TPair noAnn noAnn noAnn noAnn
              (Mo.Ty Mo.TInt noAnn)
              (Mo.Ty Mo.TString noAnn)
            )
            noAnn
          )
        )
        noAnn

    rightCombPairWithAnns :: Mo.Ty
    rightCombPairWithAnns =
      Mo.Ty
        (Mo.TPair "x" noAnn noAnn noAnn
          (Mo.Ty Mo.TUnit "t1")
          (Mo.Ty
            (Mo.TPair "y" "z" noAnn noAnn
              (Mo.Ty Mo.TInt "t2")
              (Mo.Ty Mo.TString "t3")
            )
            noAnn
          )
        )
        "t"

test_tuple_type :: [TestTree]
test_tuple_type = testSatisfyingCases P.type_
  [ ( "(int, int, bool, unit, nat)"
    , Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))
    )
  , ( "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))"
    , Right (bigPair 16)
    )
  ]
  where
    bigPair :: Integer -> Ty
    bigPair n | n == 0 = tynat
    bigPair n          = typair tynat (bigPair (n - 1))

test_or_type :: [TestTree]
test_or_type =
  testSatisfyingCases P.type_
    [ ("or unit unit", Right unitOr)
    , ("(unit | unit)", Right unitOr)
    ]
  ++ testSatisfyingCasesPredicate P.type_
    [ ("(chain_id | (int | (string | bool)))", isRight)
    , ("or unit unit kek", isLeft)
    ]
  where
    unitOr :: Mo.Ty
    unitOr =
      Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn

test_lambda_type :: [TestTree]
test_lambda_type =
  satisfyingCasePredicate P.type_ "lambda int (signature, int)" isRight :
  testSatisfyingCases P.type_
    [ ("lambda unit unit", Right lambdaUnitUnit)
    , ("\\unit -> unit", Right lambdaUnitUnit)
    ]
  where
    lambdaUnitUnit :: Mo.Ty
    lambdaUnitUnit =
      Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn

test_list_type :: [TestTree]
test_list_type =
  satisfyingCasePredicate P.type_ "[(key, key)]" isRight :
  testSatisfyingCases P.type_
    [ ("list unit", Right unitList)
    , ("[unit]", Right unitList)
    ]
  where
    unitList :: Mo.Ty
    unitList =
      Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn

test_set_type :: [TestTree]
test_set_type = testSatisfyingCases P.type_
  [ ("set int", Right intSet)
  , ("set (pair int int)", Right intPairSet)
  , ("{int}", Right intSet)
  , ("{(pair int int)}", Right intPairSet)
  ]
  where
    intSet :: Mo.Ty
    intSet =
      Mo.Ty (Mo.TSet (Mo.Ty Mo.TInt noAnn)) noAnn
    intPairSet :: Mo.Ty
    intPairSet =
      Mo.Ty (Mo.TSet (Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TInt noAnn) (Mo.Ty Mo.TInt Mo.noAnn)) noAnn)) noAnn

----------------------------------------------------------------------------
-- Constructors
----------------------------------------------------------------------------

test_Pair_constructor :: [TestTree]
test_Pair_constructor =
  [ testGroup "simple pair constructor" $ testSatisfyingCases P.value
    [ ("Pair Unit Unit", Right unitPair)
    , ("(Unit, Unit)", Right unitPair)
    ]

  , testGroup "right-combed pair consrtuctor" $ testSatisfyingCases P.value
    [ ("Pair Unit 3 \"Hi\"", Right unitPairRightCombed)
    , ("(Unit, 3, \"Hi\")", Right unitPairRightCombed)
    ]
  ]
  where
    unitPair :: Mo.Value' Mo.ParsedOp
    unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit

    unitPairRightCombed :: Mo.Value' Mo.ParsedOp
    unitPairRightCombed = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi"))

----------------------------------------------------------------------------
-- Comments
----------------------------------------------------------------------------

test_block_comment :: [TestTree]
test_block_comment =
  testSatisfyingCases PL.mSpace $
    [ "/* */"
    , " /* */"
    , "/* */ "
    , "/* */;"
    , "/* */ ;"
    , "/* */\n;"
    ]
    `zip` repeat (Right ())

----------------------------------------------------------------------------
-- Delimiters
----------------------------------------------------------------------------

test_mandatory_spaces :: [TestTree]
test_mandatory_spaces =
  [ testGroup "delimiters inside single value" $ testSatisfyingCasesPredicate P.value
    [ ("Pair 1Unit", isLeft)
    , ("Pair 1/*a*/2", isRight)
    -- TODO [#744]: The next two cases should be both
    -- either valid expressions or invalid, depending on
    -- the fact what is an intended behaviour
    , ("Pair\"1\"Unit", isLeft)
    , ("Pair 1\"2\"", isLeft)
    ]

  , testGroup "delimiters inside single instruction" $ testSatisfyingCasesPredicate P.parsedOp
  -- there have to be at least one delimiter
  -- between instruction items, either space or block comment
    [ ("PUSHint 1", isLeft)
    , ("PUSH int1", isLeft)
    , ("PUSH int#a\n1", isLeft)
    , ("PUSH int/*a*/1", isRight)
    , ("PUSH int 1", isRight)
    -- TODO [#744]: The next two cases should be both
    -- either valid expressions or invalid, depending on
    -- the fact what is an intended behaviour
    , ("PUSH string\"1\"", isLeft)
    , ("PUSH (pair string int) (Pair\"1\"2)", isLeft)
    ]

  , testGroup "delimiters between instructions" $ testSatisfyingCasesPredicate P.ops
  -- instructions might not be separated by @;@
  -- iff the first one is a sequence @{a; b;...} z@
    [ ("{{ } NIL operation {}}", isLeft)
    , ("{ DROP SWAP }", isLeft)
    , ("{DROP    ; SWAP;}", isRight)
    , ("{{DROP}SWAP}", isRight)
    , ("{DROP; DIP{SWAP}}", isRight)
    ]

  , testGroup "delimiters inside type" $ (:)
  -- delimiters inside type: there might be no space after
  -- type if it's followed by one of @, | : ] .@
    ( satisfyingCasePredicate (P.letInner P.parsedOp)
        "f :: forall a. '[int] -> '[a,int,...] = {PUSH int 1};" isRight)
    ( testSatisfyingCasesPredicate P.type_
      [ ("(int,int)", isRight)
      , ("(string|nat)", isRight)
      , ("unit:u", isRight)
      , ("[int]", isRight)
      ]
    )
  ]

----------------------------------------------------------------------------
-- Others
----------------------------------------------------------------------------

test_printComment :: [TestTree]
test_printComment = testSatisfyingCases P.printComment
  [ ( "\"Sides are %[0] x %[1]\""
    , Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])
    )
  , ( "\"%[0] x\""
    , Right (PrintComment [Right (StackRef 0), Left " x"])
    )
  , ( "\"%[0]x%[1]\""
    , Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])
    )
  , ( "\"%[0]%[1]\""
    , Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])
    )
  , ( "\"xxx\""
    , Right (PrintComment [Left "xxx"])
    )
  , ( "\"\""
    , Right (PrintComment [])
    )
  ]

test_parser_exception :: [TestTree]
test_parser_exception =
  [ handleCustomError "0x000" P.value OddNumberBytesException
  , handleCustomError "Right 0x000" P.value OddNumberBytesException
  , handleCustomError "\"aaa\\r\"" P.stringLiteral
      (StringLiteralException (InvalidEscapeSequence 'r'))
  , handleCustomError "\"aaa\\b\"" P.stringLiteral
      (StringLiteralException (InvalidEscapeSequence 'b'))
  , handleCustomError "\"aaa\\t\"" P.stringLiteral
      (StringLiteralException (InvalidEscapeSequence 't'))
  , handleCustomError "\"aaa\n\"" P.stringLiteral
      (StringLiteralException (InvalidChar '\n'))
  , handleCustomError "\"aaa\r\"" P.stringLiteral
      (StringLiteralException (InvalidChar '\r'))
  , handleCustomError "{ TAG 2 (int | string) }" P.codeEntry
      (WrongTagArgs 2 (UnsafePositive 2))
  , handleCustomError "{ ACCESS 2 2 }" P.codeEntry
      (WrongAccessArgs 2 (UnsafePositive 2))
  , handleCustomError "{ SET 2 2 }" P.codeEntry
      (WrongSetArgs 2 (UnsafePositive 2))
  , handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };"
      (P.letInner P.parsedOp)
      (Tokens ('n' :| ""))
  ]

test_letType :: [TestTree]
test_letType = testSatisfyingCasesPredicate P.letType
  [ ("type kek = int", isRight)
  -- They used to be prohibited, but now we permit them.
  , ("type Parameter = int", isRight)
  , ("type Storage = int", isRight)
  ]
----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

checkFile :: Bool -> FilePath -> IO ()
checkFile shouldParse file = do
  code <- Utf8.readFile file
  case parse P.programExt file code of
    Left err
      | shouldParse -> assertFailure $ errorBundlePretty err
    Right _
      | not shouldParse -> assertFailure $ "Managed to parse " <> file
    _ -> pass

handleCustomError
  :: HasCallStack => Text -> Parser' LetEnv a -> CustomParserException -> TestTree
handleCustomError text parser customException = testCase (toString text) $
  case P.parseNoEnv parser codeSrc text of
    Right _ -> assertFailure "expecting parser to fail"
    Left bundle -> case toList $ bundleErrors bundle of
      [FancyError _ (toList -> [ErrorCustom e])] ->
        e `shouldBe` customException
      _ ->
        assertFailure $
          "expecting single ErrorCustom, but got " <>
          errorBundlePretty bundle

handleTrivialError
  :: HasCallStack => Text -> Parser' LetEnv a -> ErrorItem Char -> TestTree
handleTrivialError text parser errorItem = testCase (toString text) $
  case P.parseNoEnv parser codeSrc text of
    Right _ -> assertFailure "expecting parser to fail"
    Left bundle -> case toList $ bundleErrors bundle of
      [TrivialError _ e _] ->
        e `shouldBe` (Just errorItem)
      _ ->
        assertFailure $
          "expecting single TrivialError, but got " <>
          errorBundlePretty bundle

satisfyingCasePredicate
  :: Show a
  => Parser' LetEnv a
  -> Text
  -> (Either (ParseErrorBundle Text CustomParserException) a -> Bool)
  -> TestTree
satisfyingCasePredicate parser parsedExpression predicate =
  testCase (toString parsedExpression) $
    P.parseNoEnv parser codeSrc parsedExpression `shouldSatisfy` predicate

satisfyingCase
  :: (Eq a, Show a)
  => Parser' LetEnv a
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
  -> TestTree
satisfyingCase parser parsedExpression expected =
  satisfyingCasePredicate parser parsedExpression (== expected)

testSatisfyingCases
  :: (Eq a, Show a)
  => Parser' LetEnv a
  -> [(Text, Either (ParseErrorBundle Text CustomParserException) a)]
  -> [TestTree]
testSatisfyingCases parser = map (uncurry $ satisfyingCase parser)

testSatisfyingCasesPredicate
  :: Show a
  => Parser' LetEnv a
  -> [(Text, Either (ParseErrorBundle Text CustomParserException) a -> Bool)]
  -> [TestTree]
testSatisfyingCasesPredicate parser = map (uncurry $ satisfyingCasePredicate parser)