Import.hs

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

{-# LANGUAGE QuasiQuotes #-}

-- | Test on importing functionality.
module Test.Import
  ( test_importContract
  , test_importSomeContract
  , test_importUntypedContract
  , test_readContract
  , test_readValue
  , test_Basic
  ) where

import Control.Exception (handle)
import Data.List.NonEmpty ()
import Data.Vinyl (Rec(..))
import Test.HUnit ((@?), (@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)

import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos)
import Morley.Michelson.Parser (codeSrc)
import Morley.Michelson.Typed
import Morley.Michelson.Untyped qualified as U
import Morley.Util.Interpolate
import Test.Cleveland hiding (importContract, importUntypedContract)
import Test.Cleveland.Instances ()
import Test.Cleveland.Michelson
import Test.Cleveland.Michelson.Import
import Test.Util.Contracts

applyContract :: Contract ('TLambda ('TPair 'TInt 'TInt) 'TInt) 'TInt
applyContract = $$(embedContract (inContractsDir "apply.tz"))

-- | This is a clone of one of the tests but written using 'embedContract'.
test_Basic :: TestTree
test_Basic = testScenarioOnEmulator "" $ scenario do
  hndl <- originateUntypedSimple "apply" (U.ValueInt 0) $ convertContract applyContract
  let
    lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ]
    lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB
  transfer TransferData
    { tdTo = hndl
    , tdAmount = 0
    , tdEntrypoint = DefEpName
    , tdParameter = VLam $ RfNormal lam }
  getStorage @Integer hndl @@== 2

test_readContract :: TestTree
test_readContract = testGroup "Test 'readContract'"
  [ testCase emptyFilePath $
      second convertContract (readContract @'TUnit @'TUnit codeSrc emptyCode) @?=
        Right emptyContractUPrim
  , testCase basic2FilePath $
      second convertContract (
        readContract @TPairInt @TListPairInt codeSrc basic2Code) @?=
          Right basic2ContractUPrim
  , testCase basic3FilePath $
      isLeft (readContract @TPairInt @TListPairInt codeSrc basic3Code)
        @? "Contract should parse"
  ]

test_importContract :: TestTree
test_importContract = testGroup "Test 'importContract'"
  [ testCase emptyFilePath $ do
      contract <- importContract @'TUnit @'TUnit (contractsDir </> emptyFilePath)
      convertContract contract @?= emptyContractUPrim
  , testCase basic2FilePath $ do
      contract <- importContract @TPairInt @TListPairInt (contractsDir </> basic2FilePath)
      convertContract contract @?= basic2ContractUPrim
  , testCase basic3FilePath $ do
      handle @ContractReadError (\_ -> pass) $ do
        _ <- importContract @TPairInt @TListPairInt (contractsDir </> basic3FilePath)
        assertFailure "No exception is raised"
  ]

test_importSomeContract :: TestTree
test_importSomeContract = testGroup "Test 'importSomeContract'"
  [ testCase emptyFilePath $ do
      SomeContract contract <- importSomeContract (contractsDir </> emptyFilePath)
      convertContract contract @?= emptyContractUPrim
  , testCase basic2FilePath $ do
      SomeContract contract <- importSomeContract (contractsDir </> basic2FilePath)
      convertContract contract @?= basic2ContractUPrim
  , testCase basic3FilePath $ do
      handle @ContractReadError (\_ -> pass) $ do
        _ <- importSomeContract (contractsDir </> basic3FilePath)
        assertFailure "No exception is raised"
  ]


test_importUntypedContract :: TestTree
test_importUntypedContract = testGroup "Test 'importUntypedContract'"
  [ testCase emptyFilePath $ do
      contractU <- importUntypedContract (contractsDir </> emptyFilePath)
      contractU @?= emptyContractU
  , testCase basic2FilePath $ do
      contractU <- importUntypedContract (contractsDir </> basic2FilePath)
      contractU @?= basic2ContractU
  , testCase "Non-parsable contract" $ do
      handle @ContractReadError (\_ -> pass) $ do
        _ <- importUntypedContract (contractsDir </> "unparsable" </> "chain_id_arity.tz")
        assertFailure "No exception is raised"
  ]

test_readValue :: TestTree
test_readValue = testGroup "Test 'readValue'"
  [ testCase "1" $
      (readValue @'TNat codeSrc "1") @?= Right (VNat 1)
  , testCase "{1; 2}" $
      (readValue @('TList 'TString) codeSrc "{\"a\"; \"b\"}") @?=
        Right (VList [VString "a", VString "b"])
  , testCase "Pair 1 \"a\"" $
      (readValue @('TPair 'TInt 'TString) codeSrc "Pair 1 \"a\"") @?=
        Right (VPair (VInt 1, VString "a"))
  , testCase "{something}" $
      isLeft (readValue @'TBool codeSrc "{something}")
        @? "Should parse"
  ]


-- Contracts' relative filePaths

emptyFilePath :: FilePath
emptyFilePath = "tezos_examples/attic/empty.tz"

basic2FilePath :: FilePath
basic2FilePath = "basic2.tz"

basic3FilePath :: FilePath
basic3FilePath = "ill-typed/basic3.tz"


-- Text contracts

emptyCode :: Text
emptyCode =
  [itu|
  parameter unit;
  storage unit;
  code {CDR; NIL operation; PAIR}
  |]

basic2Code :: Text
basic2Code =
  [itu|
  parameter (pair (int %x) (int :x));
  storage (list (pair int (int %y)));
  code {
        DUP; CAR; DIP { CDR; };
        CONS;
        NIL operation; PAIR; };
  |]

basic3Code :: Text
basic3Code =
  [itu|
  parameter (pair (int %x) int);
  storage (list (pair (int %z) int));
  code {
        DUP; CAR; DIP { CDR; };
        CONS;
        NIL operation; PAIR; };
  |]


-- Untyped Michelson contracts

-- We need two versions of each untyped contract for the tests.
-- First is a contract which 'contractCode' is based on 'PrimEx'
-- due to the fact that 'convertContract' uses this constructor
-- to produce untyped contract.
-- Second has 'WithSrcEx' for this purpose
-- because it is a way how untyped contracts are parsed.

emptyContractUPrim :: U.Contract
emptyContractUPrim =
  U.Contract
    { contractParameter = U.ParameterType U.tyunit U.noAnn
    , contractStorage = U.tyunit
    , contractCode = U.PrimEx <$>
        [ U.CDR U.noAnn U.noAnn
        , U.NIL U.noAnn U.noAnn tyoperation
        , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn
        ]
    , entriesOrder = U.PSC
    , contractViews = []
    }

emptyContractU :: U.Contract
emptyContractU =
  U.Contract
    { contractParameter = U.ParameterType U.tyunit U.noAnn
    , contractStorage = U.tyunit
    , contractCode =
        [ locExpanded 2 6  $ U.CDR U.noAnn U.noAnn
        , locExpanded 2 11 $ U.NIL U.noAnn U.noAnn tyoperation
        , locExpanded 2 26 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn
        ]
    , entriesOrder = U.PSC
    , contractViews = []
    }

basic2ContractUPrim :: U.Contract
basic2ContractUPrim =
  U.Contract
    { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn
    , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn
    , contractCode = U.PrimEx <$>
        [ U.DUP U.noAnn
        , U.CAR U.noAnn U.noAnn
        , U.DIP [U.PrimEx $ U.CDR U.noAnn U.noAnn]
        , U.CONS U.noAnn
        , U.NIL U.noAnn U.noAnn tyoperation
        , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn
        ]
    , entriesOrder = U.PSC
    , contractViews = []
    }

basic2ContractU :: U.Contract
basic2ContractU =
  U.Contract
    { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn
    , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn
    , contractCode =
        [ locExpanded 7 6  $ U.DUP U.noAnn
        , locExpanded 7 11 $ U.CAR U.noAnn U.noAnn
        , locExpanded 7 16 $ U.DIP [locExpanded 7 22 $ U.CDR U.noAnn U.noAnn]
        , locExpanded 8 6  $ U.CONS U.noAnn
        , locExpanded 9 6  $ U.NIL U.noAnn U.noAnn tyoperation
        , locExpanded 9 21 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn
        ]
    , entriesOrder = U.PSC
    , contractViews = []
    }


-- Helpers

locExpanded :: Word -> Word -> U.ExpandedInstr -> U.ExpandedOp
locExpanded line col ei =
  let noCallStack = InstrCallStack [] $ srcPos line col
  in U.WithSrcEx noCallStack $ U.PrimEx ei

locInstr :: Word -> Word -> Instr a b -> Instr a b
locInstr line col = WithLoc $ InstrCallStack [] $ srcPos line col

withNotes
  :: forall a inp out. SingI a
  => Notes a
  -> Instr inp (a : out)
  -> Instr inp (a : out)
withNotes notes = InstrWithNotes Proxy (notes :& RNil)

withVarAnn :: U.VarAnn -> Instr inp out -> Instr inp out
withVarAnn = InstrWithVarAnns . U.OneVarAnn

tyoperation :: U.Ty
tyoperation = U.Ty U.TOperation U.noAnn

type TPairInt = 'TPair 'TInt 'TInt

type TListPairInt = 'TList ('TPair 'TInt 'TInt)