-- SPDX-FileCopyrightText: 2021 Tocqueville Group -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ {-# 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 qualified Morley.Michelson.Untyped 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)