diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,54 @@ +0.1.1 +===== +* [!1113](https://gitlab.com/morley-framework/morley/-/merge_requests/1113) + Remove uses of `Parser LetEnv` due to redundant constraint. +* [!1094](https://gitlab.com/morley-framework/morley/-/merge_requests/1094) + Deprecate morley language extensions + + Functions for importing and testing Morley contracts are added: `Test.Cleveland.Michelson.Import.testTreesWithUntypedContractExt`, `Test.Cleveland.Michelson.Import.testTreesWithTypedContractExt`, `Test.Cleveland.Lorentz.Import.importContractExt`. All these functions are considered deprecated. +* [!965](https://gitlab.com/morley-framework/morley/-/merge_requests/965) + Use Morley's fixed-size lists + + Add Hedgehog generators for sized lists. + + Introduce `enumAliasHints` for generating a sized list of similarly named alias hints. +* [!1072](https://gitlab.com/morley-framework/morley/-/merge_requests/1072) + Add `runCode` to Cleveland +* [!1070](https://gitlab.com/morley-framework/morley/-/merge_requests/1070) + Simplify cleveland's internals & public api + + Relaced the `NiceUnpackedValue (AsRPC st)` constraint in `getStorage` + + Removed the `NicePackedValue k` constraint from `getAllBigMapValuesMaybe`, + `getAllBigMapValues`, `getBigMapSizeMaybe`, and `getBigMapSize`. +* [!1025](https://gitlab.com/morley-framework/morley/-/merge_requests/1025) + Reduce the number of unsafe functions at the call site + + Remove `unsafeFromHex` converter that is used as counter-part of safe `fromHex` and replaced with `unsafe . fromHex`. + + Refactor `fromHex` to return `Either` instead of `Maybe`. + + Add `parseAddressFromHex` helper to get rid of duplicated usages of `parseAddressRaw . unsafe . fromHex`. +* [!978](https://gitlab.com/morley-framework/morley/-/merge_requests/978) + Make it difficult to misuse 'Show' + + Use `Buildable` and `pretty` preferrentially. + + Add `Buildable` instances for `FaluireReason`, `Either a b`. + + Add `PrettyShow` instances for `TypeSpec` (in lorentz-test) and `Time _` (in cleveland itself)./ + + Avoid using `(+||)` and `(||+)`. + + Use `Debug.show` when defining `Show` instances. +* [!1058](https://gitlab.com/morley-framework/morley/-/merge_requests/1058) + Add `Buildable` instances for Unit, tuples up to 8 elements & bytestrings +* [!1057](https://gitlab.com/morley-framework/morley/-/merge_requests/1057) + Test `Show` and `RenderDoc` instances of `Annotation t`, `AnnotationSet`, `Notes t`, `InstrAbstract op` +* [!997](https://gitlab.com/morley-framework/morley/-/merge_requests/997) + Check necessity in initial `cast` automatically in Lorentz contracts +* [!1044](https://gitlab.com/morley-framework/morley/-/merge_requests/1044) + Fix `getRunMode` and `whenEmulated` + + `getRunMode` is replaced by `ifEmulation` helper. + + A new helper `whenNetwork` is added. + + One caveat is that functions passed to `ifEmulation` are universally quantified over the outer monad, so if additional constraints are required beyond `MonadCleveland` or `MonadEmulated`, those constraints have to go on the base monad, e.g. `(MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m ()`. +ifEmulation. +* [!1043](https://gitlab.com/morley-framework/morley/-/merge_requests/1043) + Extract actual + expected pattern into a datatype and show diff in type mismatch +* [!1037](https://gitlab.com/morley-framework/morley/-/merge_requests/1037) + Add synonyms for `SomeConstrainedValue` + + Reimplement `SomeConstant`, `SomeValue`, `SomeStorage` via `SomeConstrainedValue`. + 0.1.0 ===== Initial release extracted from the [morley](https://hackage.haskell.org/package/morley) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,6 @@ -MIT License Copyright (c) 2020 Tocqueville Group +MIT License +Copyright (c) 2021-2022 Oxhead Alpha +Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/cleveland.cabal b/cleveland.cabal --- a/cleveland.cabal +++ b/cleveland.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: cleveland -version: 0.1.0 +version: 0.1.1 synopsis: Testing framework for Morley. description: This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz. These tests can be run on an emulated environment or on a real network. category: Blockchain @@ -13,7 +13,7 @@ bug-reports: https://gitlab.com/morley-framework/morley/-/issues author: Serokell, Tocqueville Group maintainer: Serokell -copyright: 2020 Tocqueville Group +copyright: 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple @@ -36,6 +36,7 @@ Hedgehog.Gen.Michelson.Typed Hedgehog.Gen.Michelson.Untyped Hedgehog.Gen.Morley.Micheline + Hedgehog.Gen.SizedList Hedgehog.Gen.Tezos.Address Hedgehog.Gen.Tezos.Core Hedgehog.Gen.Tezos.Crypto @@ -44,6 +45,7 @@ Hedgehog.Gen.Tezos.Crypto.P256 Hedgehog.Gen.Tezos.Crypto.Secp256k1 Hedgehog.Gen.Tezos.Crypto.Timelock + Lorentz.Test.DupableScan Test.Cleveland Test.Cleveland.Doc Test.Cleveland.Doc.Common @@ -104,24 +106,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -137,6 +141,7 @@ , MonadRandom , aeson , base-noprelude >=4.7 && <5 + , bytestring , constraints >=0.11 , containers , criterion @@ -199,12 +204,14 @@ TestSuite.Cleveland.Level TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator TestSuite.Cleveland.Lorentz.Entrypoints + TestSuite.Cleveland.MismatchError TestSuite.Cleveland.NewAddressCheck TestSuite.Cleveland.OperationReplay TestSuite.Cleveland.PrefixNetworkScenario TestSuite.Cleveland.PrettyFailWith TestSuite.Cleveland.PublicKeyToAddress TestSuite.Cleveland.RefillableAddress + TestSuite.Cleveland.RunCode TestSuite.Cleveland.StorageCheck TestSuite.Cleveland.StorageWithBigMaps TestSuite.Cleveland.Tasty @@ -245,24 +252,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -295,6 +304,7 @@ , tasty , tasty-hedgehog , tasty-hunit-compat + , temporary , text , time default-language: Haskell2010 @@ -314,18 +324,21 @@ Test.Lorentz.CustomValue Test.Lorentz.DeadCode Test.Lorentz.Doc.Positions + Test.Lorentz.DupableScan Test.Lorentz.Entrypoints Test.Lorentz.Entrypoints.Doc Test.Lorentz.Errors Test.Lorentz.Errors.Numeric Test.Lorentz.Expr Test.Lorentz.Extensible + Test.Lorentz.Instr.MapOption Test.Lorentz.Interpreter Test.Lorentz.Macro Test.Lorentz.MorleyLogs Test.Lorentz.Optimizer Test.Lorentz.Pack Test.Lorentz.Print + Test.Lorentz.Product Test.Lorentz.ReferencedByName Test.Lorentz.Storage Test.Lorentz.StoreClass.ComplexRefs @@ -369,24 +382,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -431,6 +446,7 @@ main-is: Main.hs other-modules: Test.Fee + Test.RPCKeyRevealing Tree Test.Util.Contracts Paths_cleveland @@ -458,24 +474,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -489,8 +507,10 @@ build-tool-depends: tasty-discover:tasty-discover build-depends: - base-noprelude >=4.7 && <5 + HUnit + , base-noprelude >=4.7 && <5 , cleveland + , cryptonite , directory , filepath , morley @@ -505,6 +525,7 @@ main-is: Main.hs other-modules: Test.Analyzer + Test.AsRPC Test.Doc.Position Test.Entrypoints Test.Ext @@ -535,6 +556,7 @@ Test.Macro Test.Michelson.Parser.Value Test.Michelson.Runtime + Test.Michelson.Show Test.Michelson.Text Test.Michelson.Typed.AnnotatedValue Test.Michelson.Typed.Convert @@ -563,6 +585,7 @@ Test.Util.Hedgehog Test.Util.HUnit Test.Util.Parser + Test.Util.TH Test.ValConversion Test.Views Tree @@ -592,24 +615,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -655,6 +680,7 @@ , tasty-hedgehog , tasty-hspec , tasty-hunit-compat + , template-haskell , text , unordered-containers , vinyl @@ -689,24 +715,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections diff --git a/lorentz-test/Main.hs b/lorentz-test/Main.hs --- a/lorentz-test/Main.hs +++ b/lorentz-test/Main.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Main ( main diff --git a/lorentz-test/Test/Doc.hs b/lorentz-test/Test/Doc.hs --- a/lorentz-test/Test/Doc.hs +++ b/lorentz-test/Test/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on automatic documentation generation. @@ -11,7 +10,8 @@ , test_fakeCoerce ) where -import qualified Data.Set as Set +import Data.Set qualified as Set +import Data.Text.Lazy.Builder (toLazyText) import Fmt (build) import Hedgehog (evalNF, property) import Test.HUnit (assertBool, assertFailure, (@?=)) @@ -20,9 +20,10 @@ import Test.Tasty.Hedgehog (testProperty) import Lorentz ((#)) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Michelson.Doc import Morley.Michelson.Typed +import Morley.Util.Markdown import Morley.Util.Named import Test.Cleveland.Doc.Lorentz @@ -79,8 +80,10 @@ case lookupDocBlockSection subcontents of Just (DDescription "a" :| []) -> pass - _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents - _ -> assertFailure $ "Unexpected contents: " <> show contents + _ -> assertFailure $ toString $ toLazyText $ + "Unexpected subcontents: " <> docBlockToMarkdown (HeaderLevel 1) subcontents + _ -> assertFailure $ toString $ toLazyText $ + "Unexpected contents: " <> docBlockToMarkdown (HeaderLevel 1) contents ] -- Test on loops on dependency graph of doc items diff --git a/lorentz-test/Test/DocTest.hs b/lorentz-test/Test/DocTest.hs --- a/lorentz-test/Test/DocTest.hs +++ b/lorentz-test/Test/DocTest.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on doc test framework. module Test.DocTest @@ -13,7 +12,7 @@ import Test.Tasty.HUnit (testCase) import Lorentz ((#), (/->)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Entrypoints.Doc import Morley.Michelson.Doc import Test.Cleveland.Doc diff --git a/lorentz-test/Test/Lorentz/BLS12381.hs b/lorentz-test/Test/Lorentz/BLS12381.hs --- a/lorentz-test/Test/Lorentz/BLS12381.hs +++ b/lorentz-test/Test/Lorentz/BLS12381.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} @@ -14,7 +13,7 @@ import Test.HUnit (Assertion, (@?=)) -import qualified Morley.Tezos.Crypto.BLS12381 as BLS +import Morley.Tezos.Crypto.BLS12381 qualified as BLS pairingCheckCode :: Lambda (Bls12381G1, Bls12381G2) Bool pairingCheckCode = do diff --git a/lorentz-test/Test/Lorentz/Base.hs b/lorentz-test/Test/Lorentz/Base.hs --- a/lorentz-test/Test/Lorentz/Base.hs +++ b/lorentz-test/Test/Lorentz/Base.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for basic Lorentz functionality. diff --git a/lorentz-test/Test/Lorentz/Case.hs b/lorentz-test/Test/Lorentz/Case.hs --- a/lorentz-test/Test/Lorentz/Case.hs +++ b/lorentz-test/Test/Lorentz/Case.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on mere @case@ in Lorentz (without entrypoints). module Test.Lorentz.Case @@ -13,7 +12,7 @@ import Test.Tasty.HUnit (testCase) import Lorentz ((#), (/->)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Run.Simple import Morley.Michelson.Typed (IsoValue) diff --git a/lorentz-test/Test/Lorentz/Conditionals.hs b/lorentz-test/Test/Lorentz/Conditionals.hs --- a/lorentz-test/Test/Lorentz/Conditionals.hs +++ b/lorentz-test/Test/Lorentz/Conditionals.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} diff --git a/lorentz-test/Test/Lorentz/ContractRegistry.hs b/lorentz-test/Test/Lorentz/ContractRegistry.hs --- a/lorentz-test/Test/Lorentz/ContractRegistry.hs +++ b/lorentz-test/Test/Lorentz/ContractRegistry.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,7 +12,7 @@ import Lorentz import Prelude hiding (drop) -import qualified Data.Map as Map +import Data.Map qualified as Map import System.Directory (removeFile) import System.Directory.Internal.Prelude (isDoesNotExistError) import Test.HUnit (Assertion, assertFailure) @@ -50,7 +49,7 @@ checkAndRemoveFile file = removeFile file `catch` \e -> if isDoesNotExistError e - then assertFailure $ "File " <> show file <> " was not created" + then assertFailure $ "File \"" <> file <> "\" was not created" else throwM e unit_contractRegistryCommands :: Assertion diff --git a/lorentz-test/Test/Lorentz/CustomArith.hs b/lorentz-test/Test/Lorentz/CustomArith.hs --- a/lorentz-test/Test/Lorentz/CustomArith.hs +++ b/lorentz-test/Test/Lorentz/CustomArith.hs @@ -1,8 +1,7 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA --- | Note: This extension is enabled because it allows better representation of tests +-- Note: This extension is enabled because it allows better representation of tests -- with @BinBase@. These tests require special representation behavior because 'show' works -- incorrect with non-decimal base. {-# LANGUAGE HexFloatLiterals #-} @@ -14,7 +13,7 @@ ) where import Prelude hiding (div) -import Test.Tasty +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Lorentz diff --git a/lorentz-test/Test/Lorentz/CustomValue.hs b/lorentz-test/Test/Lorentz/CustomValue.hs --- a/lorentz-test/Test/Lorentz/CustomValue.hs +++ b/lorentz-test/Test/Lorentz/CustomValue.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Checks that the strategies for 'Morley.Util.CustomGeneric' work as expected to -- produce 'IsoValue' with a custom shape. @@ -15,6 +14,7 @@ import GHC.TypeNats (type (-)) import Test.Tasty (TestTree) +import Lorentz.Layouts.NonDupable import Lorentz.Value import Morley.Michelson.Typed.T @@ -157,6 +157,20 @@ deriving anyclass instance IsoValue a => IsoValue (NewType a) +data SemiDupableType = SemiDupableType + { _sdt1 :: Integer + , _sdt2 :: Natural + , _sdt3 :: ByteString + , _sdt4 :: MText + , _sdt5 :: () + , _sdt6 :: Ticket Integer + , _sdt7 :: Ticket Natural + } + +$(deriveSemiDupableGeneric "SemiDupableType" 2) + +deriving anyclass instance IsoValue SemiDupableType + ---------------------------------------------------------------------------- -- Expected resulting IsoValue ---------------------------------------------------------------------------- @@ -213,6 +227,11 @@ type ExpectedLigoCombSumValue = 'TOr 'TInt 'TUnit +type ExpectedSemiDupableValue = + 'TPair + ('TPair ('TPair 'TInt 'TNat) ('TPair 'TBytes ('TPair 'TString 'TUnit))) + ('TPair ('TTicket 'TInt) ('TTicket 'TNat)) + ---------------------------------------------------------------------------- -- Type equality checking ---------------------------------------------------------------------------- @@ -259,3 +278,6 @@ _checkNewType :: ToT (NewType a) :~: ToT (CustomType a) _checkNewType = Refl + +_checkSemiDupable :: ToT SemiDupableType :~: ExpectedSemiDupableValue +_checkSemiDupable = Refl diff --git a/lorentz-test/Test/Lorentz/DeadCode.hs b/lorentz-test/Test/Lorentz/DeadCode.hs --- a/lorentz-test/Test/Lorentz/DeadCode.hs +++ b/lorentz-test/Test/Lorentz/DeadCode.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- TODO [#549]: remove this pragma {-# OPTIONS_GHC -Wno-deprecations #-} @@ -17,11 +16,11 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Base import Lorentz.Run import Morley.Michelson.Typed (Instr(Seq)) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T test_Test :: [TestTree] test_Test = diff --git a/lorentz-test/Test/Lorentz/Doc/Positions.hs b/lorentz-test/Test/Lorentz/Doc/Positions.hs --- a/lorentz-test/Test/Lorentz/Doc/Positions.hs +++ b/lorentz-test/Test/Lorentz/Doc/Positions.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on ordering of documentation items. module Test.Lorentz.Doc.Positions diff --git a/lorentz-test/Test/Lorentz/DupableScan.hs b/lorentz-test/Test/Lorentz/DupableScan.hs new file mode 100644 --- /dev/null +++ b/lorentz-test/Test/Lorentz/DupableScan.hs @@ -0,0 +1,97 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Tests on 'Lorentz.Test.DupableScan' module. +module Test.Lorentz.DupableScan + ( test_checkDupablesDistribution + , test_testDupablesDistribution + ) where + +import Data.Constraint (Dict(..)) +import Data.Typeable (typeRep) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Lorentz.Layouts +import Lorentz.Test.DupableScan +import Lorentz.Value + +data ProperSample = ProperSample + { _s1a :: Integer + , _s1b :: MText + , _s1c :: Ticket () + , _s1d :: Ticket Natural + } deriving stock (Generic) + +data MisplacedDupableSample = MisplacedDupableSample + { _s2a :: Integer + , _s2b :: MText + , _s2c :: Natural + , _s2d :: Ticket Natural + } deriving stock (Generic) + +data MisplacedNonDupableSample = MisplacedNonDupableSample + { _s3a :: Ticket ByteString + , _s3b :: MText + , _s3c :: Ticket () + , _s3d :: Ticket Natural + } deriving stock (Generic) + +data CombGenericSample = CombGenericSample + { _s4a :: Integer + , _s4b :: Ticket () + , _s4c :: Ticket Integer + , _s4d :: Ticket Natural + } + +customGeneric "CombGenericSample" rightComb + +test_checkDupablesDistribution :: [TestTree] +test_checkDupablesDistribution = + [ testCase "Good type" $ + checkDupablesDistribution @ProperSample @?= Right () + + , testCase "Misplaced dupable" $ + checkDupablesDistribution @MisplacedDupableSample @?= Left BadElement + { beExpectedDupability = False + , beRecName = Just "_s2c" + , beRecType = typeRep (Proxy @Natural) + } + + , testCase "Misplaced non-dupable" $ + checkDupablesDistribution @MisplacedNonDupableSample @?= Left BadElement + { beExpectedDupability = True + , beRecName = Just "_s3a" + , beRecType = typeRep (Proxy @(Ticket ByteString)) + } + + , testCase "Comb generic" $ + checkDupablesDistribution @CombGenericSample @?= Right () + + ] + +-- Two ways to test product type layout + +test_testDupablesDistribution :: TestTree +test_testDupablesDistribution = testDupablesDistribution @ProperSample + +_test_typeVerifyDupablesDistribution :: Dict (VerifyDupablesDistribution ProperSample) +_test_typeVerifyDupablesDistribution = Dict + +-- Checking that deriveSemiDupableGeneric matches with our test utilities +---------------------------------------------------------------------------- + +data MegaType = MegaType + { _mt1 :: Integer + , _mt2 :: Natural + , _mt3 :: () + , _mt4 :: MText + , _mt5 :: ByteString + , _mt6 :: Ticket Natural + , _mt7 :: Ticket Integer + } + +deriveSemiDupableGeneric "MegaType" 2 + +_test_MegaType_layout :: Dict (VerifyDupablesDistribution MegaType) +_test_MegaType_layout = Dict diff --git a/lorentz-test/Test/Lorentz/Entrypoints.hs b/lorentz-test/Test/Lorentz/Entrypoints.hs --- a/lorentz-test/Test/Lorentz/Entrypoints.hs +++ b/lorentz-test/Test/Lorentz/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. module Test.Lorentz.Entrypoints @@ -21,7 +20,7 @@ import Test.TypeSpec (Is, TypeSpec(..)) import Lorentz ((#), (/->)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Annotation import Lorentz.Constraints import Lorentz.Entrypoints @@ -45,7 +44,7 @@ | Do3 MyEntrypoints2 | Do4 MyParams deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints1a = Do1a Integer @@ -53,7 +52,7 @@ | Do3a MyEntrypoints2 | Do4a MyParams deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints2 = Do10 @@ -65,49 +64,49 @@ = Do12 ("tuplearg" :! ("TL" :! Integer, "TR" :! Natural), "boolarg" :! Bool) | Do13 ("integerarg" :! Integer, "boolarg" :! Bool) deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints4 = Do14 ("viewarg1" :! L.View_ ("owner" :! L.Address) Natural) | Do15 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints5 = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural)) | Do17 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints6 = Do18 ("lambdaarg" :! L.Lambda Natural Natural) | Do19 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints7 = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)]) | Do21 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints8 = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address))) | Do23 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints9 = Do24 ("maybearg" :? ("maybeinner" :! Natural)) | Do25 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints10 = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ()) | Do27 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints11 = Do28 ("kek" :! Natural, "pek" :! Integer) @@ -119,19 +118,19 @@ = Default Integer | NonDefault Natural deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypointsWithRoot = Dor1 | Dor2 Natural deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypointsWithCustomAnn = Doc1 Natural | Doc2 CustomProd deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data CustomProd = CustomProd { cp1 :: Natural @@ -167,7 +166,7 @@ = Dod1 | Dod2 MyEntrypointsSubDelegated deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypointsSubDelegated = Dosd1 @@ -452,10 +451,10 @@ => EntrypointRef mname -> arg -> Contract (TAddress cp ()) () () -callerContract epRef arg = L.defaultContract $ +callerContract epRef argument = L.defaultContract $ L.car # L.contractCalling epRef # L.assertSome ("Contract lookup failed" :: MText) # - L.push 1 # L.push arg # L.transferTokens # + L.push 1 # L.push argument # L.transferTokens # L.dip (L.unit # L.nil) # L.cons # L.pair test_Contract_call :: [TestTree] diff --git a/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs b/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs --- a/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs +++ b/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on autodoc for entrypoints. module Test.Lorentz.Entrypoints.Doc @@ -15,7 +14,7 @@ import Test.Tasty.HUnit (testCase) import Lorentz ((/->), (:->)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Annotation import Lorentz.Doc import Lorentz.Entrypoints @@ -46,7 +45,7 @@ = Do1 Integer | Do2 MySub deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance TypeHasDoc MyPlainEps where typeDocMdDescription = "MyPlainEps" @@ -67,7 +66,7 @@ = Dor1 Integer | Dor2 MySub deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints MyRecursiveEps where type ParameterEntrypointsDerivation MyRecursiveEps = EpdRecursive @@ -83,7 +82,7 @@ = Dod1 Integer | Dod2 MyPlainEps deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints MyDelegateEps where type ParameterEntrypointsDerivation MyDelegateEps = EpdDelegate @@ -106,7 +105,7 @@ = Do0 | Default deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance TypeHasDoc MyDefEps where typeDocMdDescription = "MyDefEps" @@ -128,7 +127,7 @@ = Dord1 MySub | Dord2 MyDefEps deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints MyRecursiveDefEps where type ParameterEntrypointsDerivation MyRecursiveDefEps = EpdRecursive diff --git a/lorentz-test/Test/Lorentz/Errors.hs b/lorentz-test/Test/Lorentz/Errors.hs --- a/lorentz-test/Test/Lorentz/Errors.hs +++ b/lorentz-test/Test/Lorentz/Errors.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -14,8 +13,8 @@ import Lorentz as L -import qualified Data.Bimap as Bimap -import qualified Data.HashSet as HS +import Data.Bimap qualified as Bimap +import Data.HashSet qualified as HS import Test.Tasty (TestTree) import Test.Tasty.HUnit (Assertion, (@?=)) diff --git a/lorentz-test/Test/Lorentz/Errors/Numeric.hs b/lorentz-test/Test/Lorentz/Errors/Numeric.hs --- a/lorentz-test/Test/Lorentz/Errors/Numeric.hs +++ b/lorentz-test/Test/Lorentz/Errors/Numeric.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,7 +12,7 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Base import Lorentz.Doc import Lorentz.Errors diff --git a/lorentz-test/Test/Lorentz/Expr.hs b/lorentz-test/Test/Lorentz/Expr.hs --- a/lorentz-test/Test/Lorentz/Expr.hs +++ b/lorentz-test/Test/Lorentz/Expr.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} diff --git a/lorentz-test/Test/Lorentz/Extensible.hs b/lorentz-test/Test/Lorentz/Extensible.hs --- a/lorentz-test/Test/Lorentz/Extensible.hs +++ b/lorentz-test/Test/Lorentz/Extensible.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Lorentz.Extensible ( test_Extensible diff --git a/lorentz-test/Test/Lorentz/Instr/MapOption.hs b/lorentz-test/Test/Lorentz/Instr/MapOption.hs new file mode 100644 --- /dev/null +++ b/lorentz-test/Test/Lorentz/Instr/MapOption.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Tests for 'map' instruction over 'Maybe' (a.k.a. @option@) +module Test.Lorentz.Instr.MapOption + ( test_mapOption + ) where + +import Hedgehog (forAll, property) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Lorentz +import Prelude hiding (drop, map) +import Test.Tasty.Hedgehog + +import Test.Tasty (TestTree) + +import Test.Cleveland + +exampleMapContract :: Contract (Maybe Integer) Integer () +exampleMapContract = defaultContract $ + unpair # + map (add # push @Natural 0) # + drop # + nil # + pair + +test_mapOption :: [TestTree] +test_mapOption = + [ testScenario "MAP over option int" $ scenario do + handle <- originateSimple "map example contract" 123 exampleMapContract + call handle CallDefault Nothing + getStorage handle @@== 123 + call handle CallDefault (Just 321) + getStorage handle @@== 444 + call handle CallDefault Nothing + getStorage handle @@== 444 + , testProperty "MAP over option int randomized test" $ property do + let intGen = Gen.integral (Range.linear -10000 10000) + st <- forAll intGen + arg <- forAll $ Gen.maybe intGen + testScenarioProps $ scenario do + handle <- originateSimple "map example contract" st exampleMapContract + call handle CallDefault arg + getStorage handle @@== (fromMaybe 0 arg + st) + ] diff --git a/lorentz-test/Test/Lorentz/Interpreter.hs b/lorentz-test/Test/Lorentz/Interpreter.hs --- a/lorentz-test/Test/Lorentz/Interpreter.hs +++ b/lorentz-test/Test/Lorentz/Interpreter.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + module Test.Lorentz.Interpreter ( test_Entry_points_lookup , test_Entry_points_calling @@ -10,26 +12,27 @@ import System.FilePath (()) import Test.Tasty (TestTree, testGroup) -import Lorentz (EpdPlain, HasAnnotation, ParameterHasEntrypoints(..), toAddress) +import Lorentz (EpdPlain, ParameterHasEntrypoints(..), toAddress) import Morley.Michelson.Text import Morley.Michelson.Typed (IsoValue(..)) -import qualified Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Cleveland +import Test.Cleveland.Lorentz.Import (importContractExt) import Test.Cleveland.Michelson (testTreesWithTypedContract) data Contract1Parameter = Contract11 Integer | Contract12 MText deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data Self1Parameter = Self11 Integer | Self12 () deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints Contract1Parameter where type ParameterEntrypointsDerivation Contract1Parameter = EpdPlain @@ -121,7 +124,7 @@ call1 <- importContract @Address @_ @() $ dir "call1.mtz" callerRef <- originateSimple "caller" () call1 - contract1 <- importContract @Contract1Parameter @_ @() $ dir "contract1.mtz" + contract1 <- runIO $ importContractExt @Contract1Parameter @_ @() $ dir "contract1.mtz" targetRef <- originateSimple "target" 0 contract1 transfer TransferData @@ -134,7 +137,7 @@ getStorage @Integer targetRef @@== 5 , testScenario "Calling some entrypoint in SELF" $ scenario do - self1 <- importContract @Self1Parameter @_ @() $ dir "self1.mtz" + self1 <- runIO $ importContractExt @Self1Parameter @_ @() $ dir "self1.mtz" contractRef <- originateSimple "self" 0 self1 transfer TransferData diff --git a/lorentz-test/Test/Lorentz/Macro.hs b/lorentz-test/Test/Lorentz/Macro.hs --- a/lorentz-test/Test/Lorentz/Macro.hs +++ b/lorentz-test/Test/Lorentz/Macro.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz macros. -- @@ -9,21 +8,107 @@ -- type-level numbers) module Test.Lorentz.Macro - ( unit_duupX + ( unit_dropX + , unit_cloneX + , unit_duupX + , unit_framedN + , unit_pair , unit_replaceN , unit_updateN + + , unit_papair + , unit_ppaiir + , unit_cdar + , unit_cddr + , unit_caar + , unit_cadr + , unit_setCar + , unit_setCdr + , unit_mapCar + , unit_mapCdr + , unit_ifRight + , unit_ifSome + , unit_when_ + , unit_unless_ + , unit_whenSome + , unit_whenNone + + , unit_mapInsert + , unit_mapInsertNew + , unit_deleteMap + , unit_setInsert + , unit_setInsertNew + , unit_setDelete + + , unit_addressToEpAddress + , test_pushContractRef + , unit_dupTop2 + , unit_fromOption + , unit_isSome + , unit_non + , unit_non' + , unit_isEmpty + , unit_nonZero + , test_execute , test_applicate ) where -import Lorentz import Prelude hiding (drop, swap) -import Test.HUnit (Assertion, (@?=)) +import Data.Map qualified as M +import Data.Set qualified as S +import Debug qualified (show) + +import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) +import Lorentz qualified as L +import Lorentz +import Morley.Tezos.Address (parseAddress) +import Test.Cleveland + (call, expectFailedWith, originateSimple, scenarioEmulated, testScenarioOnEmulator) + +---------------------------------------------------------------------------- +-- Macros parameterized with type-level numbers +---------------------------------------------------------------------------- + +unit_dropX :: Assertion +unit_dropX = do + dropX @0 @?= dropX0 + dropX @1 @?= dropX1 + dropX @2 @?= dropX2 + dropX @1 @?= dropX1' + where + dropX0 :: '[Bool] :-> '[] + dropX0 = dipN @0 drop + + dropX1 :: [Bool, Integer] :-> '[Bool] + dropX1 = dipN @1 drop + + dropX2 :: [Bool, Integer, Bool] :-> [Bool, Integer] + dropX2 = dipN @2 drop + + dropX1' :: [Bool, Integer, Bool] :-> [Bool, Bool] + dropX1' = dipN @1 drop + +unit_cloneX :: Assertion +unit_cloneX = do + cloneX @0 @?= cloneX0 + cloneX @1 @?= cloneX1 + cloneX @2 @?= cloneX2 + where + cloneX0 :: [Bool, Integer] :-> [Bool, Integer] + cloneX0 = nop + + cloneX1 :: [Bool, Integer] :-> [Bool, Bool, Integer] + cloneX1 = dup # nop + + cloneX2 :: [Bool, Integer] :-> [Bool, Bool, Bool, Integer] + cloneX2 = dup # dup # nop + unit_duupX :: Assertion unit_duupX = do duupX @1 @?= duupX1 @@ -39,6 +124,54 @@ duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool] duupX3 = dupN @3 +unit_framedN :: Assertion +unit_framedN = do + framedN @0 nop @?= framedN0 + framedN @1 drop @?= framedN1 + framedN @2 cons @?= framedN2 + framedN @3 (eq # L.and) # framedN @2 cons @?= framedNC + where + framedN0 :: '[Bool] :-> '[Bool] + framedN0 = framed @'[Bool] @'[] @'[] nop + + framedN1 :: [Bool, (), Integer] :-> [(), Integer] + framedN1 = framed @[(), Integer] @'[Bool] @'[] drop + + framedN2 :: [Bool, [Bool]] :-> '[[Bool]] + framedN2 = framed @'[] @[Bool, [Bool]] @'[[Bool]] cons + + framedNC :: [Integer, Integer, Bool, [Bool], Integer] :-> [[Bool], Integer] + framedNC = + framed @[[Bool], Integer] @[Integer, Integer, Bool] @'[Bool] (eq # L.and) # + framed @'[Integer] @[Bool, [Bool]] @'[[Bool]] cons + +unit_pair :: Assertion +unit_pair = do + carN @0 @?= carN0 + carN @1 @?= carN1 + carN @2 @?= carN2 + cdrN @0 @?= cdrN0 + cdrN @1 @?= cdrN1 + cdrN @2 @?= cdrN2 + where + carN0 :: '[(Bool, Integer), Integer] :-> '[Bool, Integer] + carN0 = pairGet @1 + + carN1 :: '[(Integer, (Bool, Integer))] :-> '[Bool] + carN1 = pairGet @3 + + carN2 :: [(Integer, (Integer, (Bool, Integer))), Integer] :-> [Bool, Integer] + carN2 = pairGet @5 + + cdrN0 :: '[(Integer, Bool)] :-> '[(Integer, Bool)] + cdrN0 = pairGet @0 + + cdrN1 :: [(Integer, Bool), Integer] :-> [Bool, Integer] + cdrN1 = pairGet @2 + + cdrN2 :: '[(Integer, (Integer, Bool))] :-> '[Bool] + cdrN2 = pairGet @4 + unit_replaceN :: Assertion unit_replaceN = do replaceN @1 @?= swap # drop @@ -65,6 +198,287 @@ updateN3 :: [Bool, Integer, (), [Bool]] :-> [Integer, (), [Bool]] updateN3 = dug @2 # dipN @2 cons + +---------------------------------------------------------------------------- +-- Other syntactic conveniences macros +---------------------------------------------------------------------------- + +unit_papair :: Assertion +unit_papair = do + papair @?= papair' + where + papair' :: '[Bool, Integer, ()] :-> '[((Bool, Integer), ())] + papair' = pair # pair + +unit_ppaiir :: Assertion +unit_ppaiir = do + ppaiir @?= ppaiir' + where + ppaiir' :: '[Bool, Integer, ()] :-> '[(Bool, (Integer, ()))] + ppaiir' = dip pair # pair + +unit_cdar :: Assertion +unit_cdar = do + cdar @?= cdar' + where + cdar' :: '[(Bool, (Integer, ()))] :-> '[Integer] + cdar' = cdr # car + +unit_cddr :: Assertion +unit_cddr = do + cddr @?= cddr' + where + cddr' :: '[(Bool, (Integer, ()))] :-> '[()] + cddr' = cdr # cdr + +unit_caar :: Assertion +unit_caar = do + caar @?= caar' + where + caar' :: '[((Bool, Integer), ())] :-> '[Bool] + caar' = car # car + +unit_cadr :: Assertion +unit_cadr = do + cadr @?= cadr' + where + cadr' :: '[((Bool, Integer), ())] :-> '[Integer] + cadr' = car # cdr + +unit_setCar :: Assertion +unit_setCar = do + setCar @?= setCar' + where + setCar' :: '[(Bool, Integer), ()] :-> '[((), Integer)] + setCar' = cdr # swap # pair + +unit_setCdr :: Assertion +unit_setCdr = do + setCdr @?= setCdr' + where + setCdr' :: '[(Bool, Integer), ()] :-> '[(Bool, ())] + setCdr' = car # pair + +unit_mapCar :: Assertion +unit_mapCar = do + mapCar L.not @?= mapCar' + where + mapCar' :: '[(Integer, Bool)] :-> '[(Integer, Bool)] + mapCar' = unpair # L.not # pair + +unit_mapCdr :: Assertion +unit_mapCdr = do + mapCdr L.not @?= mapCdr' + where + mapCdr' :: '[(Bool, Integer)] :-> '[(Bool, Integer)] + mapCdr' = unpair # dip L.not # pair + +unit_ifRight :: Assertion +unit_ifRight = do + ifRight L.not (dup # L.compare # eq0) @?= ifRight' + where + ifRight' :: '[Either Integer Bool] :-> '[Bool] + ifRight' = ifLeft (dup # L.compare # eq0) L.not + +unit_ifSome + :: Assertion +unit_ifSome = do + ifSome (dup # L.compare # eq0) (push True) @?= ifSome' + where + ifSome' :: '[Maybe Integer] :-> '[Bool] + ifSome' = ifNone (push True) (dup # L.compare # eq0) + +unit_when_ :: Assertion +unit_when_ = do + when_ (push 5 # add @Integer) @?= when_' + push 3 # push True # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 8 + push 3 # push False # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 3 + where + when_' :: '[Bool, Integer] :-> '[Integer] + when_' = if_ (push 5 # add @Integer) nop + +unit_unless_ :: Assertion +unit_unless_ = do + unless_ (push 5 # add @Integer) @?= unless_' + push 3 # push True # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 3 + push 3 # push False # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 8 + where + unless_' :: '[Bool, Integer] :-> '[Integer] + unless_' = if_ nop (push 5 # add @Integer) + +unit_whenSome :: Assertion +unit_whenSome = do + whenSome drop @?= whenSome' + where + whenSome' :: '[Maybe Integer] :-> '[] + whenSome' = ifSome drop nop + +unit_whenNone :: Assertion +unit_whenNone = do + whenNone (push True) @?= whenNone' + where + whenNone' :: '[Maybe Bool] :-> '[Bool] + whenNone' = ifNone (push True) nop + +unit_mapInsert :: Assertion +unit_mapInsert = do + mapInsert @?= mapInsert' + where + mapInsert' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool] + mapInsert' = dip L.some # update + +unit_mapInsertNew :: Assertion +unit_mapInsertNew = do + mapInsertNew nop @?= mapInsertNew' + mapInsertNewValid -$? () @?= Right (M.singleton 5 True) + let mapInsertFail = mapInsertNewInvalid -$? () + assertBool (Debug.show mapInsertFail <> " should fail") $ isLeft mapInsertFail + where + mapInsertNew' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool] + mapInsertNew' = dip L.some # dup # dip getAndUpdate # swap # ifNone drop (drop # nop # failWith) + + mapInsertNewValid :: '[] :-> '[Map Integer Bool] + mapInsertNewValid = emptyMap # push True # push 5 # mapInsertNew nop + + mapInsertNewInvalid :: '[] :-> '[Map Integer Bool] + mapInsertNewInvalid = + emptyMap # + push True # push 5 # mapInsertNew nop # + push True # push 5 # mapInsertNew nop + +unit_deleteMap :: Assertion +unit_deleteMap = do + deleteMap @?= deleteMap' + where + deleteMap' :: '[Integer, Map Integer Bool] :-> '[Map Integer Bool] + deleteMap' = dip (none @Bool) # update + +unit_setInsert :: Assertion +unit_setInsert = do + setInsert @?= setInsert' + where + setInsert' :: '[Integer, Set Integer] :-> '[Set Integer] + setInsert' = dip (push True) # update + +unit_setInsertNew :: Assertion +unit_setInsertNew = do + setInsertNew nop @?= setInsertNew' + setInsertNewValid -$? () @?= Right (S.singleton 5 ) + let setInsertFail = setInsertNewInvalid -$? () + assertBool (Debug.show setInsertFail <> " should fail") $ isLeft setInsertFail + where + setInsertNew' :: '[Integer, Set Integer] :-> '[Set Integer] + setInsertNew' = dupTop2 # mem # if_ (nop # failWith) (dip (push True) # update) + + setInsertNewValid :: '[] :-> '[Set Integer] + setInsertNewValid = emptySet # push 5 # setInsertNew nop + + setInsertNewInvalid :: '[] :-> '[Set Integer] + setInsertNewInvalid = emptySet # push 5 # setInsertNew nop # push 5 # setInsertNew nop + +unit_setDelete :: Assertion +unit_setDelete = do + setDelete @?= setDelete' + where + setDelete' :: '[Integer, Set Integer] :-> '[Set Integer] + setDelete' = dip (push False) # update + +---------------------------------------------------------------------------- +-- Morley macros +---------------------------------------------------------------------------- + +unit_addressToEpAddress :: Assertion +unit_addressToEpAddress = do + addressToEpAddress @?= addressToEpAddress' + where + addressToEpAddress' :: '[Address] :-> '[EpAddress] + addressToEpAddress' = forcedCoerce_ + +test_pushContractRef :: [TestTree] +test_pushContractRef = + [ testScenarioOnEmulator "Invalid contract ref calling fail" $ scenarioEmulated do + expectFailedWith True $ do + originatedContract <- originateSimple "target" def $ contract' ref + call originatedContract CallDefault 1 + , testScenarioOnEmulator "Valid contract ref calling success" $ scenarioEmulated do + refContract <- originateSimple "caller" () refContract' + originatedContract <- originateSimple "target" def $ contract' $ toContractRef refContract + call originatedContract CallDefault 1 + ] + where + ref :: ContractRef Integer + ref = toContractRef $ TAddress $ unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD" + + refContract' :: Contract Integer () () + refContract' = defaultContract $ car # drop # unit # nil # pair + + contract' :: ContractRef Integer -> Contract Integer () () + contract' rf = defaultContract $ + car # + pushContractRef @Integer (drop # push True # failWith) rf # + drop # drop # + unit # nil # pair + +unit_dupTop2 :: Assertion +unit_dupTop2 = do + dupTop2 @?= dupTop2' + where + dupTop2' :: '[Bool, Integer] :-> '[Bool, Integer, Bool, Integer] + dupTop2' = dupN @2 # dupN @2 + +unit_fromOption :: Assertion +unit_fromOption = do + fromOption True @?= fromOption' + where + fromOption' :: '[Maybe Bool] :-> '[Bool] + fromOption' = ifSome nop (push True) + +unit_isSome :: Assertion +unit_isSome = do + isSome @?= isSome' + where + isSome' :: '[Maybe Integer] :-> '[Bool] + isSome' = ifSome (drop # push True) (push False) + +unit_non :: Assertion +unit_non = do + non 1 @?= non_ + where + non_ :: '[Integer] :-> '[Maybe Integer] + non_ = non' (push 1 # eq) + +unit_non' :: Assertion +unit_non' = do + non' (push 0 # eq) @?= non'_ + where + non'_ :: '[Integer] :-> '[Maybe Integer] + non'_ = dup # framed (push 0 # eq :: Lambda Integer Bool) # if_ (drop # none) L.some + +unit_isEmpty :: Assertion +unit_isEmpty = do + isEmpty @?= isEmpty' + where + isEmpty' :: '[[Integer]] :-> '[Bool] + isEmpty' = size # int # eq0 + +unit_nonZero :: Assertion +unit_nonZero = do + nonZero @?= nonZeroI + nonZero @?= nonZeroN + nonZero @?= nonZeroT + where + nonZeroI :: '[Integer] :-> '[Maybe Integer] + nonZeroI = dup # eq0 # if_ (drop # none) L.some + + nonZeroN :: '[Natural] :-> '[Maybe Natural] + nonZeroN = dup # int # eq0 # if_ (drop # none) L.some + + nonZeroT :: '[Ticket Natural] :-> '[Maybe (Ticket Natural)] + nonZeroT = readTicket # toField #rtAmount # int # eq0 # if_ (drop # none) L.some + +---------------------------------------------------------------------------- +-- Execute and applicate +---------------------------------------------------------------------------- test_execute :: [TestTree] test_execute = diff --git a/lorentz-test/Test/Lorentz/MorleyLogs.hs b/lorentz-test/Test/Lorentz/MorleyLogs.hs --- a/lorentz-test/Test/Lorentz/MorleyLogs.hs +++ b/lorentz-test/Test/Lorentz/MorleyLogs.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for checking MorleyLogs processing. module Test.Lorentz.MorleyLogs @@ -17,15 +16,21 @@ import Test.Cleveland import Test.Cleveland.Michelson (testTreesWithUntypedContract) +singleLog :: Lorentz.Contract () () () +singleLog = defaultContract $ + printComment "log" # car # nil # pair + +multiLog :: Lorentz.Contract () () () +multiLog = defaultContract $ + printComment "log1" # car # nil # printComment "log2" # pair # printComment "log3" + test_MorleyLogs :: IO [TestTree] test_MorleyLogs = testTreesWithUntypedContract "../../contracts/empties.tz" $ \withoutLogs -> - testTreesWithUntypedContract "../../contracts/single_log.mtz" $ \withSingleLog -> - testTreesWithUntypedContract "../../contracts/multiple_logs.mtz" $ \withMultiLogs -> pure [ testGroup "Checking MorleyLogs processing" [ testScenarioOnEmulator "Calling contract with single log" $ scenarioEmulated do - idAddr <- originateS withSingleLog + idAddr <- originateS logsInfo <- getMorleyLogs_ $ do call idAddr CallDefault () call idAddr CallDefault () @@ -34,8 +39,8 @@ , testScenarioOnEmulator "Calling several contracts with and without logs" $ scenarioEmulated do idAddrW <- originateW withoutLogs - idAddrS <- originateS withSingleLog - idAddrM <- originateM withMultiLogs + idAddrS <- originateS + idAddrM <- originateM logsInfo <- getMorleyLogs_ $ do call idAddrW CallDefault () call idAddrS CallDefault () @@ -46,8 +51,8 @@ collectLogs logsInfo @== MorleyLogs ["log", "log1", "log2", "log3"] , testScenarioOnEmulator "Calling several contracts to check the logging order" $ scenarioEmulated do - idAddrS <- originateS withSingleLog - idAddrM <- originateM withMultiLogs + idAddrS <- originateS + idAddrM <- originateM logsInfo <- getMorleyLogs_ $ do call idAddrS CallDefault () call idAddrM CallDefault () @@ -59,13 +64,13 @@ , testScenarioOnEmulator "Calling contracts in parallel with branchout" $ scenarioEmulated do branchout [ ("1", do - idAddr <- originateS withSingleLog + idAddr <- originateS logsInfo <- getMorleyLogs_ $ call idAddr CallDefault () logsForAddress idAddr logsInfo @== fmap MorleyLogs [["log"]]) , ("2", do - idAddr <- originateS withSingleLog + idAddr <- originateS logsInfo <- getMorleyLogs_ $ call idAddr CallDefault () collectLogs logsInfo @== MorleyLogs ["log"]) @@ -93,13 +98,15 @@ UntypedOriginateData name 100 ValueUnit c return $ toTAddress addr - originateW, originateS, originateM + originateW :: forall caps m. MonadCleveland caps m => Morley.Michelson.Untyped.Contract -> m (TAddress () ()) originateW = originateContract "without logs" - originateS = originateContract "with single log" - originateM = originateContract "with multiple logs" + + originateS, originateM :: MonadCleveland caps m => m (ContractHandle () () ()) + originateS = originateSimple "with single log" () singleLog + originateM = originateSimple "with multiple logs" () multiLog callerContract :: Lorentz.Contract (ContractRef Integer) () () callerContract = defaultContract $ diff --git a/lorentz-test/Test/Lorentz/Optimizer.hs b/lorentz-test/Test/Lorentz/Optimizer.hs --- a/lorentz-test/Test/Lorentz/Optimizer.hs +++ b/lorentz-test/Test/Lorentz/Optimizer.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for optimization of Lorentz-specific instruction sequences. module Test.Lorentz.Optimizer @@ -10,7 +9,7 @@ ) where import Lorentz ((#), (:->)) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Michelson.Optimizer (optimize) import Morley.Michelson.Typed.Util (linearizeLeft) import Test.HUnit (Assertion, (@?=)) diff --git a/lorentz-test/Test/Lorentz/Pack.hs b/lorentz-test/Test/Lorentz/Pack.hs --- a/lorentz-test/Test/Lorentz/Pack.hs +++ b/lorentz-test/Test/Lorentz/Pack.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz packing/unpacking @@ -8,9 +7,11 @@ ( test_lambda_roundtrip ) where +import Debug qualified (show) import Lorentz import Prelude hiding (drop, swap) +import Fmt (pretty) import Test.HUnit (Assertion, assertFailure, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) @@ -34,15 +35,14 @@ => Lambda i o -> Assertion lambdaRoundtripWithoutNotes l = case lUnpackValueRaw @(Lambda i o) $ lPackValueRaw l of - Left err -> assertFailure $ "Unpacking error: " <> show err + Left err -> assertFailure $ "Unpacking error: " <> pretty err Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of [] -> ul @?= l - notes -> assertFailure $ "Lambda has annotations: " <> show notes + notes -> assertFailure $ "Lambda has annotations: " <> pretty notes where - dfsSettings :: DfsSettings [Text] dfsSettings = def { dsGoToValues = True} instrNotes :: Instr inp out -> [Text] instrNotes = \case - InstrWithNotes _ n _ -> [show n] + InstrWithNotes _ n _ -> [Debug.show n] _ -> [] diff --git a/lorentz-test/Test/Lorentz/Print.hs b/lorentz-test/Test/Lorentz/Print.hs --- a/lorentz-test/Test/Lorentz/Print.hs +++ b/lorentz-test/Test/Lorentz/Print.hs @@ -1,16 +1,16 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on Lorentz contracts pretty-printing. module Test.Lorentz.Print ( test_Print_parameter_annotations , test_Print_lambda , unit_Erase_annotations + , unit_Does_not_erase_annotations ) where import Lorentz hiding (contract, unpack) -import qualified Lorentz as L +import Lorentz qualified as L import Prelude hiding (drop, swap) import Test.HUnit (Assertion, assertEqual, (@?=)) @@ -57,8 +57,8 @@ ] data TestParam - = TestCon1 ("a" :! Natural, "b" :! Bool) - | TestCon2 () + = TestCon1 ("a" :! Natural, "b" :! Natural) + | TestCon2 Bool deriving stock Generic deriving anyclass IsoValue @@ -68,12 +68,52 @@ unit_Erase_annotations :: Assertion unit_Erase_annotations = let - myContract :: Contract TestParam () () + myContract :: Contract TestParam Bool () myContract = defaultContract $ - cdr # nil # L.pair + car + # entryCase @TestParam (Proxy @PlainEntrypointsKind) + ( #cTestCon1 /-> + unpair + # dip (fromNamed #b) + # fromNamed #a + # eq + , #cTestCon2 /-> nop + ) + # nil + # L.pair - expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };" + expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\ + \code { CAST (pair (or (pair nat nat) bool) bool);CAR;IF_LEFT { UNPAIR;COMPARE;EQ }\ + \ { };NIL operation;PAIR };" in assertEqual "Printed Lorentz contract is supposed to have an instruction which erases\ - \all parameter annotations, but it does not match the expected output" + \all parameter annotations, if the contract doesn't typecheck,\ + \ but it does not match the expected output" + expected (L.printLorentzContract True myContract) + +unit_Does_not_erase_annotations :: Assertion +unit_Does_not_erase_annotations = + let + myContract :: Contract TestParam Bool () + myContract = defaultContract $ + car + # entryCase @TestParam (Proxy @PlainEntrypointsKind) + ( #cTestCon1 /-> + unpair + # dip (fromNamed #b) + # fromNamed #a + # dropN @2 + # push False + , #cTestCon2 /-> nop + ) + # nil + # L.pair + + expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\ + \code { CAR;IF_LEFT { UNPAIR;DROP 2;PUSH bool False }\ + \ { };NIL operation;PAIR };" + in assertEqual + "Printed Lorentz contract is supposed to NOT have an instruction which erases\ + \all parameter annotations, if the contract DOES typecheck,\ + \ but it does not match the expected output" expected (L.printLorentzContract True myContract) diff --git a/lorentz-test/Test/Lorentz/Product.hs b/lorentz-test/Test/Lorentz/Product.hs new file mode 100644 --- /dev/null +++ b/lorentz-test/Test/Lorentz/Product.hs @@ -0,0 +1,94 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Tests on product type utilities. +module Test.Lorentz.Product + ( test_getField_and_dupables + ) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Lorentz +import Morley.Michelson.Typed.Instr +import Morley.Util.Instances () + +-- | A dupable type +type D = () + +-- | A non-dupable type +type ND = Ticket () + +data SmallDupable = SmallDupable + { _sd1 :: D + , _sd2 :: D + , _sd3 :: D + , _sd4 :: D + } deriving stock (Generic) + deriving anyclass (IsoValue) + +data BigDupable = BigDupable + { _bd1 :: SmallDupable + , _bd2 :: D + , _bd3 :: D + , _bd4 :: D + } deriving stock (Generic) + deriving anyclass (IsoValue, HasDupableGetters) + +data SmallHalfDupable = SmallHalfDupable + { _shd1 :: D + , _shd2 :: D + , _shd3 :: D + , _shd4 :: ND + } deriving stock (Generic) + deriving anyclass (IsoValue, HasDupableGetters) + +data BigHalfDupable1 = BigHalfDupable1 + { _bhd1 :: SmallDupable + , _bhd2 :: D + , _bhd3 :: D + , _bhd4 :: SmallHalfDupable + } deriving stock (Generic) + deriving anyclass (IsoValue, HasDupableGetters) + +-- | Here we primarily want to test that getters are optimal +-- (taking the existance of non-dupable types into account): +-- if halfway we can apply 'DUP' and end with a sequence of 'CAR' and 'CDR', +-- we should do so. +test_getField_and_dupables :: [TestTree] +test_getField_and_dupables = + [ testGroup "Direct field access" + + [ testCase "Picking from dupable" $ + getField @SmallDupable #_sd1 @?= I do + DUP :# CAR :# CAR + + , testCase "Picking from product becoming dupable half-way" $ + getField @SmallHalfDupable #_shd1 @?= I do + UNPAIR :# DUP :# CAR :# DIP PAIR + + , testCase "Picking from product that is non-dupable all the way along" $ + getField @SmallHalfDupable #_shd3 @?= I do + UNPAIR :# SWAP :# (UNPAIR :# DUP :# DIP PAIR) :# DIP (SWAP :# PAIR) + + ] + + , testGroup "Nested field access" + + [ testCase "Picking from dupable" $ + stGetField @BigDupable (#_bd1 :-| #_sd1) @?= I do + DUP :# CAR :# CAR :# CAR :# CAR + + , testCase "Deep picking from dupable nested type" $ + stGetField @BigHalfDupable1 (#_bhd1 :-| #_sd1) @?= I do + UNPAIR :# DUP :# CAR :# CAR :# CAR :# DIP PAIR + + , testCase "Deep picking from non-dupable nested type" $ + stGetField @BigHalfDupable1 (#_bhd4 :-| #_shd1) @?= I do + UNPAIR :# SWAP :# UNPAIR :# SWAP + :# (UNPAIR :# DUP :# CAR :# DIP PAIR) + :# DIP (SWAP :# PAIR) :# DIP (SWAP :# PAIR) + + ] + + ] diff --git a/lorentz-test/Test/Lorentz/ReferencedByName.hs b/lorentz-test/Test/Lorentz/ReferencedByName.hs --- a/lorentz-test/Test/Lorentz/ReferencedByName.hs +++ b/lorentz-test/Test/Lorentz/ReferencedByName.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Lorentz.NameReferenced' module. -- diff --git a/lorentz-test/Test/Lorentz/Storage.hs b/lorentz-test/Test/Lorentz/Storage.hs --- a/lorentz-test/Test/Lorentz/Storage.hs +++ b/lorentz-test/Test/Lorentz/Storage.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on Lorentz storage annotation parsing. @@ -14,7 +13,7 @@ import Test.Tasty.HUnit (testCase) import Lorentz ((:!)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Annotation (HasAnnotation) import Lorentz.Run hiding (Contract(..)) import Lorentz.Value @@ -85,7 +84,7 @@ } deriving stock Generic deriving anyclass (IsoValue, HasAnnotation) -dummyContract :: forall storage. L.NiceStorage storage => L.Contract () storage () +dummyContract :: forall storage. L.NiceStorageFull storage => L.Contract () storage () dummyContract = defaultContract L.fakeCoerce ---------------------------------------------------------------------------- @@ -135,7 +134,7 @@ storageAnnTree :: Contract cp st -> FieldAnnTree st storageAnnTree = extractFieldAnnTree . cStoreNotes - extractAnnotation :: forall st. L.NiceStorage st => FieldAnnTree (ToT st) + extractAnnotation :: forall st. L.NiceStorageFull st => FieldAnnTree (ToT st) extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st) test_TypeAnnotations :: [TestTree] @@ -192,5 +191,5 @@ storageAnnTree :: Contract cp st -> TypeAnnTree st storageAnnTree = extractTypeAnnTree . cStoreNotes - extractAnnotation :: forall st. L.NiceStorage st => TypeAnnTree (ToT st) + extractAnnotation :: forall st. L.NiceStorageFull st => TypeAnnTree (ToT st) extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st) diff --git a/lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs b/lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs --- a/lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs +++ b/lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Lorentz.StoreClass.ComplexRefs ( test_Nested @@ -14,10 +13,9 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@?=)) -import Lorentz.Annotation (HasAnnotation) import Lorentz.Run.Simple import Lorentz.StoreClass -import qualified Lorentz.StoreClass.Extra as E +import Lorentz.StoreClass.Extra qualified as E import Lorentz.Value import Morley.Util.Lens import Morley.Util.Named @@ -26,18 +24,18 @@ data Storage = Storage { sField1 :: SubStorage } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data SubStorage = SubStorage { ssField1 :: Group } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data Group = Group { gField :: Integer , gSubmap :: Map MText Natural } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) makeLensesWith postfixLFields ''Storage makeLensesWith postfixLFields ''SubStorage diff --git a/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs b/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs --- a/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs +++ b/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Lorentz.StoreClass.SetSubmap ( test_Simple_set @@ -8,12 +7,11 @@ import Prelude hiding (drop, swap) -import qualified Data.Set as S +import Data.Set qualified as S import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import qualified Lorentz as L -import Lorentz.Annotation (HasAnnotation) +import Lorentz qualified as L import Lorentz.Base import Lorentz.Constraints import Lorentz.Run.Simple @@ -28,7 +26,7 @@ data Storage = Storage { x :: Set MText } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) emptyStorage :: Storage emptyStorage = Storage mempty diff --git a/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs b/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs --- a/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs +++ b/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Lorentz.StoreClass.StorageEntrypoints ( test_Storage_entrypoints @@ -35,7 +34,7 @@ | GetValue (View_ () Natural) | SetSubNat (EntrypointLambda Natural Natural) deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints ParameterEpTest where type ParameterEntrypointsDerivation ParameterEpTest = EpdPlain diff --git a/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs b/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs --- a/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs +++ b/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Lorentz.StoreClass.SubmapZoom ( test_Simple_part_of_value @@ -10,12 +9,11 @@ import Prelude hiding (drop, swap) -import qualified Data.Map as M +import Data.Map qualified as M import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import qualified Lorentz as L -import Lorentz.Annotation (HasAnnotation) +import Lorentz qualified as L import Lorentz.Base import Lorentz.Constraints import Lorentz.Iso @@ -34,7 +32,7 @@ data Storage = Storage { all :: BigMap MText MapValue } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance StoreHasSubmap Storage (FieldNickname "x") MText Natural where storeSubmapOps = diff --git a/lorentz-test/Test/Lorentz/Tickets.hs b/lorentz-test/Test/Lorentz/Tickets.hs --- a/lorentz-test/Test/Lorentz/Tickets.hs +++ b/lorentz-test/Test/Lorentz/Tickets.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on basic tickets functionality. -- diff --git a/lorentz-test/Test/Lorentz/Tickets/Contracts.hs b/lorentz-test/Test/Lorentz/Tickets/Contracts.hs --- a/lorentz-test/Test/Lorentz/Tickets/Contracts.hs +++ b/lorentz-test/Test/Lorentz/Tickets/Contracts.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE NoApplicativeDo #-} @@ -130,7 +129,7 @@ | AllowancesAllow (Ticket ()) | AllowancesGet (Void_ Address Natural) deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) instance ParameterHasEntrypoints AllowancesParameter where type ParameterEntrypointsDerivation AllowancesParameter = EpdPlain diff --git a/lorentz-test/Test/Lorentz/Tickets/Helpers.hs b/lorentz-test/Test/Lorentz/Tickets/Helpers.hs --- a/lorentz-test/Test/Lorentz/Tickets/Helpers.hs +++ b/lorentz-test/Test/Lorentz/Tickets/Helpers.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on tickets helpers from "Lorentz.Tickets" module. module Test.Lorentz.Tickets.Helpers @@ -10,7 +9,7 @@ import Test.Tasty (TestTree, testGroup) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Value import Morley.Util.Named import Test.Cleveland @@ -166,3 +165,5 @@ -} _untestedContract1 :: [TestTree] _untestedContract1 = const [] allowancesContract + +{-# ANN _untestedContract1 ("HLint: ignore Evaluate" :: Text) #-} diff --git a/lorentz-test/Test/Lorentz/Timelock.hs b/lorentz-test/Test/Lorentz/Timelock.hs --- a/lorentz-test/Test/Lorentz/Timelock.hs +++ b/lorentz-test/Test/Lorentz/Timelock.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on basic timelock puzzle, i.e. 'openChest' functionality module Test.Lorentz.Timelock @@ -11,8 +10,8 @@ import Prelude (Num, fst, id, snd, (/=), (<$>)) import Hedgehog (forAll, property, withTests, (===)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) diff --git a/lorentz-test/Test/Lorentz/UParam.hs b/lorentz-test/Test/Lorentz/UParam.hs --- a/lorentz-test/Test/Lorentz/UParam.hs +++ b/lorentz-test/Test/Lorentz/UParam.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz 'UParam'. module Test.Lorentz.UParam @@ -10,12 +9,13 @@ ) where import Data.Constraint (Dict(..)) +import Fmt (Buildable, pretty) import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) import Lorentz ((/->)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Base import Lorentz.Run.Simple import Lorentz.UParam @@ -65,7 +65,7 @@ unpk :: UParam Entries -> Either EntrypointLookupError (MText, String) - unpk = fmap (second show) . unpackUParam @Show + unpk = fmap (second pretty) . unpackUParam @Buildable -- Test ADT conversion ---------------------------------------------------------------------------- diff --git a/lorentz-test/Test/Lorentz/Views.hs b/lorentz-test/Test/Lorentz/Views.hs --- a/lorentz-test/Test/Lorentz/Views.hs +++ b/lorentz-test/Test/Lorentz/Views.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz on-chain views. diff --git a/lorentz-test/Test/Lorentz/ViewsImport.hs b/lorentz-test/Test/Lorentz/ViewsImport.hs --- a/lorentz-test/Test/Lorentz/ViewsImport.hs +++ b/lorentz-test/Test/Lorentz/ViewsImport.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on importing Lorentz contracts with views. @@ -11,11 +10,12 @@ import Lorentz import Prelude hiding (drop, some, swap, take, view) +import Morley.Util.MismatchError import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Util.Contracts -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Test.Cleveland.Lorentz.Import data AllViews @@ -74,12 +74,13 @@ , testCase "One view with wrong arg type" do importContract' @WrongIdView1 `catch` \e -> - e @?= VIMViewArgMismatch T.TNat T.TInt + e @?= VIMViewArgMismatch MkMismatchError{meActual=T.TNat, meExpected=T.TInt} , testCase "One view with wrong ret type" do importContract' @WrongIdView2 `catch` \e -> - e @?= VIMViewRetMismatch (T.TPair T.TNat T.TUnit) (T.TPair T.TInt T.TUnit) + e @?= VIMViewRetMismatch MkMismatchError + {meActual=T.TPair T.TNat T.TUnit, meExpected=T.TPair T.TInt T.TUnit} , testCase "Non-existent view" do importContract' @NonExistentView @@ -92,5 +93,5 @@ , testCase "All views and one wrong view" do importContract' @WrongViewsSet `catch` \e -> - e @?= VIMViewRetMismatch T.TNever T.TUnit + e @?= VIMViewRetMismatch MkMismatchError{meActual=T.TNever, meExpected=T.TUnit} ] diff --git a/lorentz-test/Test/Tasty/TypeSpec.hs b/lorentz-test/Test/Tasty/TypeSpec.hs --- a/lorentz-test/Test/Tasty/TypeSpec.hs +++ b/lorentz-test/Test/Tasty/TypeSpec.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tasty integration for TypeSpec. module Test.Tasty.TypeSpec @@ -14,11 +13,13 @@ forall expectation. PrettyTypeSpec expectation => TypeTestCase (TypeSpec expectation) +-- According to documentation of TypeSpec, the only sensible thing we can +-- do with the spec value is to print it. +type instance PrettyShow (TypeSpec _) = () + instance IsTest TypeTestCase where -- Implementation here is similar to the one from HUnit integration run _ (TypeTestCase spec) _ = - -- According to documentation of TypeSpec, the only sensible thing we can - -- do with spec value is to print it. -- TypeSpec test suites are ensured at compile time. return . testPassed $ show spec diff --git a/lorentz-test/Test/Util/Annotation.hs b/lorentz-test/Test/Util/Annotation.hs --- a/lorentz-test/Test/Util/Annotation.hs +++ b/lorentz-test/Test/Util/Annotation.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Util.Annotation ( FieldAnnTree (..) @@ -81,3 +80,5 @@ NTNever ta -> TALeaf ta NTChest ta -> TALeaf ta NTChestKey ta -> TALeaf ta + NTSaplingState ta _ -> TALeaf ta + NTSaplingTransaction ta _ -> TALeaf ta diff --git a/lorentz-test/Test/Util/TypeSpec.hs b/lorentz-test/Test/Util/TypeSpec.hs --- a/lorentz-test/Test/Util/TypeSpec.hs +++ b/lorentz-test/Test/Util/TypeSpec.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Util.TypeSpec ( ExactlyIs @@ -9,7 +8,7 @@ import Data.Singletons.Prelude.Eq (DefaultEq) import Morley.Util.Type (If) import Morley.Util.TypeLits (ErrorMessage(..)) -import Test.TypeSpec.Core +import Test.TypeSpec.Core (EvalExpectation, FAILED, OK, PrettyTypeSpec(..)) -- | Like 'Is' but ensures that arguments match in kind. data ExactlyIs (actual :: k) (expected :: k) diff --git a/morley-bench/Main.hs b/morley-bench/Main.hs --- a/morley-bench/Main.hs +++ b/morley-bench/Main.hs @@ -1,11 +1,10 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Main (main) where import Data.Default (def) -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) +import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Gauge.Main (bench, bgroup, defaultMain, nf) import Main.Utf8 (withUtf8) import Text.Megaparsec (parse) @@ -48,7 +47,7 @@ ) dummyAddress = detGenKeyAddress "thegreatandpowerful" - dummyString = unsafeMkMText "TGAP" + dummyString = unsafe . mkMText $ "TGAP" stringCallerBench = bench stringCallerFp (nf (interpret stringCallerC T.epcPrimitive (T.toVal dummyString) (T.toVal dummyAddress) dummyGlobalCounter dummyBigMapCounter) diff --git a/morley-client-test/Main.hs b/morley-client-test/Main.hs --- a/morley-client-test/Main.hs +++ b/morley-client-test/Main.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Main ( main diff --git a/morley-client-test/Test/Fee.hs b/morley-client-test/Test/Fee.hs --- a/morley-client-test/Test/Fee.hs +++ b/morley-client-test/Test/Fee.hs @@ -1,30 +1,37 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for fee calculation implementation in 'morley-client'. module Test.Fee ( test_FeeCalculation ) where -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Morley.Client.Action (transfer) import Morley.Client.Action.Common - (OriginationData(..), TD(..), TransactionData(..), computeStorageLimit) + (OriginationData(..), RevealData(..), TD(..), TransactionData(..), computeStorageLimit, + revealKeyUnlessRevealed) import Morley.Client.Action.Operation (dryRunOperationsNonEmpty) import Morley.Client.Full (runMorleyClientM) +import Morley.Client.OnlyRPC import Morley.Client.RPC.Getters (getProtocolParameters) -import Morley.Client.TezosClient.Impl (calcOriginationFee, calcTransferFee) +import Morley.Client.TezosClient.Impl + (calcOriginationFee, calcRevealFee, calcTransferFee, importKey) import Morley.Client.TezosClient.Types - (AddressOrAlias(..), CalcOriginationFeeData(..), CalcTransferFeeData(..)) + (AddressOrAlias(..), AliasOrAliasHint(..), CalcOriginationFeeData(..), CalcTransferFeeData(..)) +import Morley.Client.Types import Morley.Micheline.Json (TezosMutez(..)) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.Typed (IsoValue(..)) import Morley.Michelson.Untyped (pattern DefEpName) -import Morley.Tezos.Core (toMutez, zeroMutez) -import Test.Cleveland (NetworkEnv(neMorleyClientEnv)) +import Morley.Tezos.Address +import Morley.Tezos.Core (tz, zeroMutez) +import Morley.Tezos.Crypto +import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 +import Test.Cleveland (NetworkEnv(neMorleyClientEnv), mkMorleyOnlyRpcEnvNetwork) import Test.Cleveland.Internal.Abstract (Moneybag(..)) import Test.Cleveland.Internal.Client (setupMoneybagAddress) import Test.Cleveland.Michelson.Import (importContract) @@ -49,11 +56,13 @@ , odStorage = toVal () , odMbFee = Nothing } + , testCase "reveal has the same fee" $ do + compareRevealFeeCalculation withEnv ] where trivialTransfer = TransactionData $ TD { tdReceiver = genesisAddress - , tdAmount = toMutez 100 + , tdAmount = 100 , tdEpName = DefEpName , tdParam = toVal () , tdMbFee = Nothing @@ -63,8 +72,9 @@ :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> NonEmpty TransactionData -> Assertion compareTransferFeeCalculation withEnv transferBatch = withEnv $ \env -> do Moneybag moneybagAddr <- setupMoneybagAddress env + runMorleyClientM (neMorleyClientEnv env) $ revealKeyUnlessRevealed moneybagAddr Nothing (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $ - dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (map Left transferBatch) + dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (map OpTransfer transferBatch) pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters feesTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcTransferFee (AddressResolved moneybagAddr) Nothing (computeStorageLimit appliedResults pp) @@ -83,8 +93,9 @@ :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> OriginationData -> Assertion compareOriginationFeeCalculation withEnv od@OriginationData{..} = withEnv $ \env -> do Moneybag moneybagAddr <- setupMoneybagAddress env + runMorleyClientM (neMorleyClientEnv env) $ revealKeyUnlessRevealed moneybagAddr Nothing (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $ - dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (one $ Right od) + dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (one $ OpOriginate od) pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters feeTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcOriginationFee CalcOriginationFeeData @@ -96,3 +107,26 @@ , cofdBurnCap = computeStorageLimit appliedResults pp } feesMorleyClient @?= [feeTezosClient] + +compareRevealFeeCalculation + :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> Assertion +compareRevealFeeCalculation withEnv = withEnv $ \env -> do + sk <- SecretKeyEd25519 <$> liftIO Ed25519.randomSecretKey + let pub = toPublic sk + let addr = mkKeyAddress pub + + alias <- runMorleyClientM (neMorleyClientEnv env) do + alias <- importKey True (AnAliasHint "rpc-revealed-key") sk + Moneybag moneybag <- liftIO $ setupMoneybagAddress env + void $ transfer moneybag addr [tz|1 milli|] DefEpName (toVal ()) Nothing + return alias + + (appliedResults, feesRPC) :| [] <- runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) do + let rd = RevealData{ rdPublicKey = pub, rdMbFee = Nothing } + dryRunOperationsNonEmpty (AddressResolved addr) (one $ OpReveal rd) + + pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters + feesTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcRevealFee + alias Nothing (computeStorageLimit [appliedResults] pp) + + feesRPC @?= feesTezosClient diff --git a/morley-client-test/Test/RPCKeyRevealing.hs b/morley-client-test/Test/RPCKeyRevealing.hs new file mode 100644 --- /dev/null +++ b/morley-client-test/Test/RPCKeyRevealing.hs @@ -0,0 +1,67 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Tests on key revealing performed via RPC. +module Test.RPCKeyRevealing + ( test_rpcKeyRevealing + ) where + +import Crypto.Random (getRandomBytes) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Morley.Client.Action qualified as WithTezosClient +import Morley.Client.Action.Reveal +import Morley.Client.Full qualified as WithTezosClient +import Morley.Client.OnlyRPC +import Morley.Client.RPC.Getters as WithTezosClient +import Morley.Client.TezosClient qualified as WithTezosClient +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U +import Morley.Tezos.Address +import Morley.Tezos.Core +import Morley.Tezos.Crypto +import Test.Cleveland +import Test.Cleveland.Tasty + +test_rpcKeyRevealing :: TestTree +test_rpcKeyRevealing = + whenNetworkEnabled $ \withEnv -> + testGroup "Key revealing via RPC" + [ testCase "Can reveal a new key" $ withEnv \env -> do + sk <- detSecretKey <$> liftIO (getRandomBytes 16) + let pub = toPublic sk + let addr = mkKeyAddress pub + + WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do + WithTezosClient.importKey True (WithTezosClient.AnAliasHint "rpc-revealed-key") sk + moneybag <- WithTezosClient.resolveAddress (WithTezosClient.AddressAlias $ neMoneybagAlias env) + void $ WithTezosClient.transfer moneybag addr [tz|1 milli|] U.DefEpName T.VUnit Nothing + + opHash <- runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) $ do + revealKey addr $ + RevealData pub Nothing + + mManager <- WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do + WithTezosClient.waitForOperation opHash + getManagerKey addr + + mManager @?= Just pub + + , testCase "revealKeyUnlessRevealed works" $ withEnv \env -> do + sk <- detSecretKey <$> liftIO (getRandomBytes 16) + let pub = toPublic sk + let addr = mkKeyAddress pub + + WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do + WithTezosClient.importKey True (WithTezosClient.AnAliasHint "rpc-revealed-key") sk + moneybag <- WithTezosClient.resolveAddress (WithTezosClient.AddressAlias $ neMoneybagAlias env) + void $ WithTezosClient.transfer moneybag addr [tz|1 milli|] U.DefEpName T.VUnit Nothing + + runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) $ do + void . revealKey addr $ + RevealData pub Nothing + void . revealKeyUnlessRevealed addr $ + RevealData pub Nothing + + ] diff --git a/morley-test/Main.hs b/morley-test/Main.hs --- a/morley-test/Main.hs +++ b/morley-test/Main.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Main ( main diff --git a/morley-test/Test/Analyzer.hs b/morley-test/Test/Analyzer.hs --- a/morley-test/Test/Analyzer.hs +++ b/morley-test/Test/Analyzer.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for analyzer. @@ -10,12 +9,12 @@ import Prelude hiding (EQ) -import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict qualified as HM import Test.HUnit (Assertion, (@?=)) import Morley.Michelson.Analyzer import Morley.Michelson.Text -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Test.Cleveland.Instances () diff --git a/morley-test/Test/AsRPC.hs b/morley-test/Test/AsRPC.hs new file mode 100644 --- /dev/null +++ b/morley-test/Test/AsRPC.hs @@ -0,0 +1,647 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_GHC -Wno-star-is-type #-} + +module Test.AsRPC + ( unit_Renames_constructors_fields_and_generic_metadata + , unit_Can_derive_many_instances_at_once + , unit_Supports_higher_kinded_types + , unit_Can_derive_instances_with_newtype + , unit_Can_derive_many_instances_with_newtypes + , unit_Can_derive_many_instances_with_type_aliases + ) where + +import Data.Typeable ((:~:)(Refl)) +import GHC.Generics + (C1, D1, DecidedStrictness(..), FixityI(..), Generic(..), K1(..), M1(..), Meta(..), Rec0, S1, + SourceStrictness(..), SourceUnpackedness(..), (:*:)(..)) +import Language.Haskell.TH.Syntax qualified as TH +import Test.Tasty.HUnit (Assertion) + +import Lorentz (BigMap, BigMapId, IsoValue(ToT), MText, customGeneric, leftBalanced, ligoLayout) +import Morley.AsRPC + +import Test.Util.TH (shouldCompileIgnoringInstance, shouldCompileTo) + +data ExampleStorage a b = ExampleStorage + { _esField1 :: Integer + , _esField2 :: [BigMap Integer MText] + , _esField3 :: a + } + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "ExampleStorage" + +unit_Renames_constructors_fields_and_generic_metadata :: Assertion +unit_Renames_constructors_fields_and_generic_metadata = do + $(deriveRPC "ExampleStorage" >>= TH.lift) `shouldCompileTo` + [d| + data ExampleStorageRPC a (b :: k) = ExampleStorageRPC + { _esField1RPC :: AsRPC Integer + , _esField2RPC :: AsRPC [BigMap Integer MText] + , _esField3RPC :: AsRPC a + } + + instance (HasRPCRepr a) => HasRPCRepr (ExampleStorage a (b :: k)) where + type AsRPC (ExampleStorage a (b :: k)) = ExampleStorageRPC a (b :: k) + + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (ExampleStorageRPC a (b :: k)) + + instance Generic (ExampleStorageRPC a (b :: k)) + where type Rep (ExampleStorageRPC a + (b :: k)) = D1 ('MetaData "ExampleStorageRPC" "Test.AsRPC" "main" 'False) + (C1 ('MetaCons "ExampleStorageRPC" 'PrefixI 'True) + ((:*:) (S1 ('MetaSel ('Just "_esField1RPC") + 'NoSourceUnpackedness + 'NoSourceStrictness + 'DecidedStrict) + (Rec0 (AsRPC Integer))) + ((:*:) (S1 ('MetaSel ('Just "_esField2RPC") + 'NoSourceUnpackedness + 'NoSourceStrictness + 'DecidedStrict) + (Rec0 (AsRPC ([BigMap Integer + MText])))) + (S1 ('MetaSel ('Just "_esField3RPC") + 'NoSourceUnpackedness + 'NoSourceStrictness + 'DecidedStrict) + (Rec0 (AsRPC a)))))) + from (ExampleStorageRPC v0 + v1 + v2) = M1 (M1 ((:*:) (M1 (K1 v0)) ((:*:) (M1 (K1 v1)) (M1 (K1 v2))))) + to (M1 (M1 ((:*:) (M1 (K1 v0)) + ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))) = ExampleStorageRPC v0 v1 v2 + |] + +data Ex1 = Ex1 Integer Ex1Inner + deriving stock Generic + deriving anyclass IsoValue +data Ex1Inner = Ex1Inner Integer + deriving stock Generic + deriving anyclass IsoValue + +data Ex2 = Ex2 Integer + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "Ex2" + +data Ex3 = Ex3 Integer + deriving stock (Generic, Eq, Ord) + deriving anyclass IsoValue + +data Ex4 a = Ex4 a + deriving stock Generic + deriving anyclass IsoValue + +data ExampleMany = ExampleMany + { _emField1 :: Integer + , _emField2 :: Ex1 + , _emField3 :: Ex2 + , _emField4 :: [BigMap Ex3 (Ex4 MText)] + } + deriving stock Generic + deriving anyclass IsoValue + +-- Check that the declarations generated by `deriveManyRPC` actually compile. +deriveManyRPC "ExampleMany" [] + +unit_Can_derive_many_instances_at_once :: Assertion +unit_Can_derive_many_instances_at_once = do + shouldCompileIgnoringInstance ''Generic + $(deriveManyRPC "ExampleMany" ["Ex3"] >>= TH.lift) + [d| + data ExampleManyRPC = ExampleManyRPC + {_emField1RPC :: AsRPC Integer + , _emField2RPC :: AsRPC Ex1 + , _emField3RPC :: AsRPC Ex2 + , _emField4RPC :: AsRPC [BigMap Ex3 (Ex4 MText)] + } + instance HasRPCRepr ExampleMany where type AsRPC ExampleMany = ExampleManyRPC + deriving anyclass instance IsoValue ExampleManyRPC + + -- An instance is generated for Ex1 + data Ex1RPC = Ex1RPC (AsRPC Integer) (AsRPC Ex1Inner) + instance HasRPCRepr Ex1 where type AsRPC Ex1 = Ex1RPC + deriving anyclass instance IsoValue Ex1RPC + + -- An instance is generated for Ex1's fields' types + data Ex1InnerRPC = Ex1InnerRPC (AsRPC Integer) + instance HasRPCRepr Ex1Inner where type AsRPC Ex1Inner = Ex1InnerRPC + deriving anyclass instance IsoValue Ex1InnerRPC + + -- No instance is generated for Ex2, because one already exists + + -- No instance is generated for Ex3, because we explicitly said we don't want one + + -- An instance is generated for BigMap's concrete type arguments + data Ex4RPC a = Ex4RPC (AsRPC a) + instance HasRPCRepr a => HasRPCRepr (Ex4 a) where type AsRPC (Ex4 a) = Ex4RPC a + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Ex4RPC a) + |] + +---------------------------------------------------------------------------- +-- Examples data types: +-- +-- Simple data type +---------------------------------------------------------------------------- + +data Simple = Simple Integer Integer [Integer] + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "Simple" + +data ExpectedSimpleRPC = ExpectedSimpleRPC Integer Integer [Integer] + deriving stock Generic + deriving anyclass IsoValue + +_checkSimple :: ToT SimpleRPC :~: ToT ExpectedSimpleRPC +_checkSimple = Refl + +---------------------------------------------------------------------------- +-- Simple record data type +---------------------------------------------------------------------------- + +data SimpleRecord = SimpleRecord + { _simpleRecordField1 :: Integer + , _simpleRecordField2 :: Integer + , _simpleRecordField3 :: [Integer] + } + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "SimpleRecord" + +data ExpectedSimpleRecordRPC = ExpectedSimpleRecordRPC + { eSimpleRecordField1 :: Integer + , eSimpleRecordField2 :: Integer + , eSimpleRecordField3 :: [Integer] + } + deriving stock Generic + deriving anyclass IsoValue + +_checkSimpleRecord :: ToT SimpleRecordRPC :~: ToT ExpectedSimpleRecordRPC +_checkSimpleRecord = Refl + +---------------------------------------------------------------------------- +-- Data type with bigmap fields +---------------------------------------------------------------------------- + +data WithBigMap = WithBigMap + { _wbmField1 :: Integer + , _wbmField2 :: BigMap Integer Integer + , _wbmField3 :: [BigMap Integer Integer] + } + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "WithBigMap" + +data ExpectedWithBigMapRPC = ExpectedWithBigMapRPC + { expectedWbmField1 :: Integer + , expectedWbmField2 :: BigMapId Integer Integer + , expectedWbmField3 :: [BigMapId Integer Integer] + } + deriving stock Generic + deriving anyclass IsoValue + +_checkWithBigMap :: ToT WithBigMapRPC :~: ToT ExpectedWithBigMapRPC +_checkWithBigMap = Refl + +---------------------------------------------------------------------------- +-- Data type with custom generic strategy +---------------------------------------------------------------------------- + +data WithGenericStrategy + = WithGenericStrategy_1 Integer Integer Integer + | WithGenericStrategy_2 Integer Integer Integer + | WithGenericStrategy_3 Integer Integer Integer + | WithGenericStrategy_4 Integer Integer Integer + +deriving anyclass instance IsoValue WithGenericStrategy +customGeneric "WithGenericStrategy" leftBalanced +deriveRPCWithStrategy "WithGenericStrategy" leftBalanced + +_checkWithGenericStrategy :: ToT WithGenericStrategyRPC :~: ToT WithGenericStrategy +_checkWithGenericStrategy = Refl + +---------------------------------------------------------------------------- +-- Data type with reordered fields +---------------------------------------------------------------------------- + +data WithReordered = WithRedordered + { _wrField1 :: Integer + , _wrField3 :: MText + , _wrField2 :: [Integer] + } + +deriving anyclass instance IsoValue WithReordered +customGeneric "WithReordered" ligoLayout +deriveRPCWithStrategy "WithReordered" ligoLayout + +_checkWithReordered :: ToT WithReorderedRPC :~: ToT WithReordered +_checkWithReordered = Refl + +---------------------------------------------------------------------------- +-- Data type with type variables +---------------------------------------------------------------------------- + +data WithTypeVariables a = WithTypeVariables + { _wtvField1 :: a + } + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "WithTypeVariables" + +data ExpectedWithTypeVariablesRPC = ExpectedWithTypeVariablesRPC + { expectedWtvField1 :: BigMapId Integer MText + } + deriving stock Generic + deriving anyclass IsoValue + +_checkWithTypeVariables :: ToT (WithTypeVariablesRPC (BigMap Integer MText)) :~: ToT ExpectedWithTypeVariablesRPC +_checkWithTypeVariables = Refl + +---------------------------------------------------------------------------- +-- Data type with nested data types and type variables +---------------------------------------------------------------------------- + +data WithNested a = WithNested + { _wnField1 :: WithNested2 a + , _wnField2 :: [WithNested2 a] + , _wnField3 :: WithNested2 [a] + } + deriving stock Generic +deriving anyclass instance IsoValue a => IsoValue (WithNested a) + +data WithNested2 a = WithNested2 + { _wn2Field1 :: a + , _wn2Field2 :: [a] + } + deriving stock Generic + deriving anyclass IsoValue + +deriveManyRPC "WithNested" [] + +data ExpectedWithNestedRPC = ExpectedWithNestedRPC + { expectedWnField1 :: ExpectedWithNested2RPC + , expectedWnField2 :: [ExpectedWithNested2RPC] + , expectedWnField3 :: ExpectedWithNested2RPC' + } + deriving stock Generic + deriving anyclass IsoValue + +data ExpectedWithNested2RPC = ExpectedWithNested2RPC + { expectedWn2Field1 :: BigMapId Integer MText + , expectedWn2Field2 :: [BigMapId Integer MText] + } + deriving stock Generic + deriving anyclass IsoValue + +data ExpectedWithNested2RPC' = ExpectedWithNested2RPC' + { expectedWn2Field1' :: [BigMapId Integer MText] + , expectedWn2Field2' :: [[BigMapId Integer MText]] + } + deriving stock Generic + deriving anyclass IsoValue + +_checkWithNested2 :: ToT (WithNested2RPC (BigMap Integer MText)) :~: ToT ExpectedWithNested2RPC +_checkWithNested2 = Refl + +_checkWithNested :: ToT (WithNestedRPC (BigMap Integer MText)) :~: ToT ExpectedWithNestedRPC +_checkWithNested = Refl + +---------------------------------------------------------------------------- +-- Data type with phantom type variables +---------------------------------------------------------------------------- + +data WithPhantom a b c = WithPhantom + { _wpField1 :: Integer + , _wpField2 :: b + } + deriving stock Generic + deriving anyclass IsoValue +deriveRPC "WithPhantom" + +data ExpectedWithPhantomRPC = ExpectedWithPhantomRPC + { expectedWpField1 :: Integer + , expectedWpField2 :: MText + } + deriving stock Generic + deriving anyclass IsoValue + +_checkWithPhantom :: ToT (WithPhantomRPC Integer MText (BigMap Integer Integer)) :~: ToT ExpectedWithPhantomRPC +_checkWithPhantom = Refl + +---------------------------------------------------------------------------- +-- Data type with higher-kinded type variables +---------------------------------------------------------------------------- + +data WithHigherKind f = WithHigherKind + { _whkField1 :: WithHigherKindNested f + } + deriving stock Generic +deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKind f) + +data WithHigherKindNested f = WithHigherKindNested + { _whknField1 :: f Integer MText + } + deriving stock Generic +deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKindNested f) + +deriveManyRPC "WithHigherKind" [] + +unit_Supports_higher_kinded_types :: Assertion +unit_Supports_higher_kinded_types = do + shouldCompileIgnoringInstance ''Generic + $(deriveManyRPC "WithHigherKind" [] >>= TH.lift) + [d| + data WithHigherKindRPC (f :: * -> * -> *) = WithHigherKindRPC + { _whkField1RPC :: AsRPC (WithHigherKindNested f) + } + + instance HasRPCRepr (WithHigherKindNested f) => HasRPCRepr (WithHigherKind (f :: * -> * -> *)) where + type AsRPC (WithHigherKind (f :: * -> * -> *)) + = WithHigherKindRPC (f :: * -> * -> *) + + deriving anyclass instance IsoValue (AsRPC (WithHigherKindNested f)) + => IsoValue (WithHigherKindRPC (f :: * -> * -> *)) + + data WithHigherKindNestedRPC (f :: * -> * -> *) = WithHigherKindNestedRPC + { _whknField1RPC :: AsRPC (f Integer MText) + } + + instance HasRPCRepr (f Integer MText) => HasRPCRepr (WithHigherKindNested (f :: * -> * -> *)) where + type AsRPC (WithHigherKindNested (f :: * -> * -> *)) + = WithHigherKindNestedRPC (f :: * -> * -> *) + + deriving anyclass instance IsoValue (AsRPC (f Integer MText)) + => IsoValue (WithHigherKindNestedRPC (f :: * -> * -> *)) + |] + +data ExpectedWithHigherKindRPC = ExpectedWithHigherKindRPC + { expectedWhkField1 :: ExpectedWithHigherKindNestedRPC + } + deriving stock Generic + deriving anyclass IsoValue + +data ExpectedWithHigherKindNestedRPC = ExpectedWithHigherKindNestedRPC + { expectedWhknField1 :: Map Integer MText + } + deriving stock Generic + deriving anyclass IsoValue + +_checkWithHigherKindNested :: ToT (WithHigherKindNestedRPC Map) :~: ToT ExpectedWithHigherKindNestedRPC +_checkWithHigherKindNested = Refl + +_checkWithHigherKind :: ToT (WithHigherKindRPC Map) :~: ToT ExpectedWithHigherKindRPC +_checkWithHigherKind = Refl + +---------------------------------------------------------------------------- +-- Newtypes allowed with deriveRPC and in deriveManyRPC +---------------------------------------------------------------------------- + +data Data1 b = Data1 b + deriving stock (Generic, Eq, Ord) + deriving anyclass IsoValue + +deriveRPC "Data1" + +newtype Nt1 a b = Nt1 [Data1 a] + deriving stock (Generic, Eq, Ord) +deriving anyclass instance IsoValue a => IsoValue (Nt1 a b) + +deriveRPC "Nt1" + +unit_Can_derive_instances_with_newtype :: Assertion +unit_Can_derive_instances_with_newtype = do + shouldCompileIgnoringInstance ''Generic + $(deriveRPC "Nt1" >>= TH.lift) + [d| + newtype Nt1RPC a (b :: k) = Nt1RPC (AsRPC ([Data1 a])) + + instance HasRPCRepr ([Data1 a]) => HasRPCRepr (Nt1 a (b :: k)) where + type AsRPC (Nt1 a (b :: k)) = Nt1RPC a (b :: k) + + deriving anyclass instance IsoValue (AsRPC ([Data1 a])) => IsoValue (Nt1RPC a (b :: k)) + |] + +newtype Nt2 = Nt2 { _nt2field :: Integer } + deriving stock Generic + deriving anyclass IsoValue + +newtype Nt3 a = Nt3 a + deriving stock Generic + deriving anyclass IsoValue + +newtype Nt4 a b = Nt4 (BigMap Integer MText) + deriving stock Generic + deriving anyclass IsoValue + +newtype Nt5 a = Nt5 a + deriving stock Generic + deriving anyclass IsoValue + +newtype Nt6 a = Nt6 (Nt5 a) + deriving stock Generic +deriving anyclass instance IsoValue a => IsoValue (Nt6 a) + +data Data2 a = Data2 (Nt6 a) + deriving stock Generic +deriving anyclass instance IsoValue a => IsoValue (Data2 a) + +data ExampleWithNewtypes = ExampleWithNewtypes + { _ewnField1 :: Nt3 Nt2 + , _ewnField2 :: Nt4 MText Integer + , _ewnField3 :: Data2 Integer + } + deriving stock Generic + deriving anyclass IsoValue + +deriveManyRPC "ExampleWithNewtypes" [] + +unit_Can_derive_many_instances_with_newtypes :: Assertion +unit_Can_derive_many_instances_with_newtypes = do + shouldCompileIgnoringInstance ''Generic + $(deriveManyRPC "ExampleWithNewtypes" [] >>= TH.lift) + [d| + data ExampleWithNewtypesRPC = ExampleWithNewtypesRPC + {_ewnField1RPC :: (AsRPC (Nt3 Nt2)) + , _ewnField2RPC :: (AsRPC (Nt4 MText Integer)) + , _ewnField3RPC :: (AsRPC (Data2 Integer)) + } + + + instance HasRPCRepr ExampleWithNewtypes where + type AsRPC ExampleWithNewtypes = ExampleWithNewtypesRPC + deriving anyclass instance IsoValue ExampleWithNewtypesRPC + + newtype Nt3RPC a = Nt3RPC (AsRPC a) + instance HasRPCRepr a => HasRPCRepr (Nt3 a) where + type AsRPC (Nt3 a) = Nt3RPC a + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt3RPC a) + + newtype Nt2RPC = Nt2RPC {_nt2fieldRPC :: (AsRPC Integer)} + instance HasRPCRepr Nt2 where + type AsRPC Nt2 = Nt2RPC + deriving anyclass instance IsoValue Nt2RPC + + newtype Nt4RPC (a :: k) (b :: k) = Nt4RPC (AsRPC (BigMap Integer MText)) + instance HasRPCRepr (Nt4 (a :: k) (b :: k)) where + type AsRPC (Nt4 (a :: k) (b :: k)) = Nt4RPC (a :: k) (b :: k) + deriving anyclass instance IsoValue (Nt4RPC (a :: k) (b :: k)) + + data Data2RPC a = Data2RPC (AsRPC (Nt6 a)) + instance HasRPCRepr (Nt6 a) => HasRPCRepr (Data2 a) where + type AsRPC (Data2 a) = Data2RPC a + deriving anyclass instance IsoValue (AsRPC (Nt6 a)) => IsoValue (Data2RPC a) + + newtype Nt6RPC a = Nt6RPC (AsRPC (Nt5 a)) + instance HasRPCRepr (Nt5 a) => HasRPCRepr (Nt6 a) where + type AsRPC (Nt6 a) = Nt6RPC a + deriving anyclass instance IsoValue (AsRPC (Nt5 a)) => IsoValue (Nt6RPC a) + + newtype Nt5RPC a = Nt5RPC (AsRPC a) + instance HasRPCRepr a => HasRPCRepr (Nt5 a) where + type AsRPC (Nt5 a) = Nt5RPC a + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt5RPC a) + |] + +---------------------------------------------------------------------------- +-- Type aliases allowed with deriveManyRPC +---------------------------------------------------------------------------- + +type Ty1 = Integer + +type Ty2 k v = BigMap k v + +type Ty3 phantom = Ty1 + +data Dt1 = Dt1 Integer + deriving stock (Generic, Eq, Ord) + deriving anyclass IsoValue + +data Dt2 a = Dt2 a + deriving stock Generic + deriving anyclass IsoValue + +type Ty4 = Dt1 + +type Ty5 a = Dt2 a + +data Dt3 k v = Dt3 k v + deriving stock (Generic, Eq, Ord) + deriving anyclass IsoValue + +type Ty6 v = Dt3 Integer v + +data Dt4 v = Dt4 (Ty6 v) + deriving stock (Generic, Eq, Ord) +deriving anyclass instance IsoValue v => IsoValue (Dt4 v) + +data Dt5 a = Dt5 a + deriving stock Generic + deriving anyclass IsoValue + +type Ty7 (f :: Type -> Type) = (f Integer) + +data Dt6 = Dt6 Integer + deriving stock (Generic, Eq, Ord) + deriving anyclass IsoValue + +data Dt7 a b = Dt7 a b + deriving stock Generic + deriving anyclass IsoValue + +data Dt8 = Dt8 [BigMap Integer MText] + deriving stock Generic + deriving anyclass IsoValue + +type Ty8 (f :: Type -> Type -> Type) a = f a Dt6 +type Ty9 (f :: Type -> Type -> Type) a = Ty8 f a +type Ty10 (f :: Type -> Type -> Type) a = Ty9 f a + +data ExampleTypeAliasMany = ExampleTypeAliasMany + { _etamField1 :: Ty1 + , _etamField2 :: Ty2 Integer MText + , _etamField3 :: Ty3 Integer + , _etamField4 :: Ty4 + , _etamField5 :: Ty5 Integer + , _etamField6 :: Ty6 MText + , _etamField7 :: Ty7 Dt5 + , _etamField8 :: Ty10 Dt7 Dt8 + , _etamField9 :: Dt4 Integer + } + deriving stock Generic + deriving anyclass IsoValue + +-- Check that the declarations generated by `deriveManyRPC` actually compile. +deriveManyRPC "ExampleTypeAliasMany" [] + +unit_Can_derive_many_instances_with_type_aliases :: Assertion +unit_Can_derive_many_instances_with_type_aliases = do + shouldCompileIgnoringInstance ''Generic + $(deriveManyRPC "ExampleTypeAliasMany" [] >>= TH.lift) + [d| + data ExampleTypeAliasManyRPC = ExampleTypeAliasManyRPC + { _etamField1RPC :: AsRPC Ty1 + , _etamField2RPC :: AsRPC (Ty2 Integer MText) + , _etamField3RPC :: AsRPC (Ty3 Integer) + , _etamField4RPC :: AsRPC Ty4 + , _etamField5RPC :: AsRPC (Ty5 Integer) + , _etamField6RPC :: AsRPC (Ty6 MText) + , _etamField7RPC :: AsRPC (Ty7 Dt5) + , _etamField8RPC :: AsRPC (Ty10 Dt7 Dt8) + , _etamField9RPC :: AsRPC (Dt4 Integer) + } + instance HasRPCRepr ExampleTypeAliasMany where + type AsRPC ExampleTypeAliasMany = ExampleTypeAliasManyRPC + deriving anyclass instance IsoValue ExampleTypeAliasManyRPC + + -- An instance is generated for Dt1 + data Dt1RPC = Dt1RPC (AsRPC Integer) + instance HasRPCRepr Dt1 where + type AsRPC Dt1 = Dt1RPC + deriving anyclass instance IsoValue Dt1RPC + + -- An instance is generated for Dt2 + data Dt2RPC a = Dt2RPC (AsRPC a) + instance HasRPCRepr a => HasRPCRepr (Dt2 a) where + type AsRPC (Dt2 a) = Dt2RPC a + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt2RPC a) + + -- An instance is generated for Dt3 + data Dt3RPC k v = Dt3RPC (AsRPC k) (AsRPC v) + instance (HasRPCRepr k, HasRPCRepr v) => HasRPCRepr (Dt3 k v) where + type AsRPC (Dt3 k v) = Dt3RPC k v + deriving anyclass instance (IsoValue (AsRPC k), IsoValue (AsRPC v)) => IsoValue (Dt3RPC k v) + + -- An instance is generated for Dt5 + data Dt5RPC a = Dt5RPC (AsRPC a) + instance HasRPCRepr a => HasRPCRepr (Dt5 a) where + type AsRPC (Dt5 a) = Dt5RPC a + deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt5RPC a) + + -- An instance is generated for Dt6 + data Dt6RPC = Dt6RPC (AsRPC Integer) + instance HasRPCRepr Dt6 where + type AsRPC Dt6 = Dt6RPC + deriving anyclass instance IsoValue Dt6RPC + + -- An instance is generated for Dt7 + data Dt7RPC a b = Dt7RPC (AsRPC a) (AsRPC b) + instance (HasRPCRepr a, HasRPCRepr b) => HasRPCRepr (Dt7 a b) where + type AsRPC (Dt7 a b) = Dt7RPC a b + deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (Dt7RPC a b) + + -- An instance is generated for Dt8 + data Dt8RPC = Dt8RPC (AsRPC ([BigMap Integer MText])) + instance HasRPCRepr Dt8 where + type AsRPC Dt8 = Dt8RPC + deriving anyclass instance IsoValue Dt8RPC + + -- An instance is generated for Dt4 + data Dt4RPC v = Dt4RPC (AsRPC (Ty6 v)) + instance HasRPCRepr (Ty6 v) => HasRPCRepr (Dt4 v) where + type AsRPC (Dt4 v) = Dt4RPC v + deriving anyclass instance IsoValue (AsRPC (Ty6 v)) => IsoValue (Dt4RPC v) + |] diff --git a/morley-test/Test/Doc/Position.hs b/morley-test/Test/Doc/Position.hs --- a/morley-test/Test/Doc/Position.hs +++ b/morley-test/Test/Doc/Position.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Doc.Position ( test_DifferentPosition diff --git a/morley-test/Test/Entrypoints.hs b/morley-test/Test/Entrypoints.hs --- a/morley-test/Test/Entrypoints.hs +++ b/morley-test/Test/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. module Test.Entrypoints @@ -15,7 +14,7 @@ import Prelude hiding (or) import Data.Default (def) -import qualified Data.Map as Map +import Data.Map qualified as Map import Fmt (pretty) import Test.HUnit (assertBool, (@?=)) import Test.Hspec (shouldSatisfy) @@ -26,13 +25,13 @@ import Hedgehog.Gen.Tezos.Address (genAddress) import Morley.Michelson.Parser (uparamTypeQ, utypeQ) import Morley.Michelson.TypeCheck (HST(..)) -import qualified Morley.Michelson.TypeCheck as TC +import Morley.Michelson.TypeCheck qualified as TC import Morley.Michelson.Typed -import Morley.Michelson.Untyped (noAnn, unsafeBuildEpName) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped (buildEpName, noAnn) +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Cleveland.Instances () -import Test.Cleveland.Util (fromHex, runGen, unsafeFromHex) +import Test.Cleveland.Util (fromHex, runGen) import Test.Util.Hedgehog @@ -58,7 +57,7 @@ unitParamType :: TC.SomeParamType unitParamType = - either (error . pretty) id $ + unsafe $ TC.mkSomeParamType (U.ParameterType U.tyunit noAnn) test_EpAddress :: [TestTree] @@ -66,7 +65,7 @@ [ testGroup "Parsing" $ [ testCase "Simple entrypoint" $ parseEpAddress (formatAddress addr <> "%ab") - @?= Right (EpAddress addr (unsafeBuildEpName "ab")) + @?= Right (EpAddress addr (unsafe . buildEpName $ "ab")) , testCase "No entrypoint" $ parseEpAddress (formatAddress addr) @@ -74,7 +73,7 @@ , testCase "Weird entrypoint" $ parseEpAddress (formatAddress addr <> "%a%b") - @?= Right (EpAddress addr (unsafeBuildEpName "a%b")) + @?= Right (EpAddress addr (unsafe . buildEpName $ "a%b")) ] , testGroup "parse . format = pure" @@ -86,11 +85,11 @@ test_ParseEpAddressRaw :: [TestTree] test_ParseEpAddressRaw = mconcat [ [ testCase ("Successfully encodes " <> toString b) - (formatEpAddress (unsafeParseEpAddressRaw (unsafeFromHex b)) @?= a) + (formatEpAddress ((unsafe . parseEpAddressRaw) (unsafe $ fromHex b)) @?= a) | (a, b) <- sampleEpAddresses ] , [ testCase ("Fails to parse invalid address " <> toString a) - ((fromHex a >>= rightToMaybe . parseEpAddressRaw) `shouldSatisfy` isNothing) + ((fromHex a >>= first pretty . parseEpAddressRaw) `shouldSatisfy` isLeft) | a <- invalidRawEpAddresses ] ] @@ -100,10 +99,10 @@ [ testGroup "Duplications are handled" $ [ testCase "One duplicated entrypoint" $ mkParamNotes (or "a" "a" prim prim) noAnn - @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [])) + @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| [])) , testCase "Several duplicated entrypoint" $ mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn - @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [unsafeBuildEpName "b"])) + @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| [unsafe . buildEpName $ "b"])) , testCase "Duplicated default entrypoint" $ mkParamNotes (or "default" "default" prim prim) noAnn @?= Left (ParamEpDuplicatedNames (DefEpName :| [])) @@ -133,7 +132,7 @@ test_ParamEpError = [ testGroup "Buildable instance" [ testCase "Duplicated entrypoints error" $ - pretty @_ @Text (ParamEpDuplicatedNames $ unsafeBuildEpName "a" :| [DefEpName]) + pretty @_ @Text (ParamEpDuplicatedNames $ unsafe (buildEpName "a") :| [DefEpName]) @?= "Duplicated entrypoint names: 'a', ''" , testCase "Uncallable arms error" $ pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight]) @@ -145,16 +144,16 @@ test_contractHasEntrypoints :: [TestTree] test_contractHasEntrypoints = [ testCase "Simple parameter" $ - U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) |] + U.mkEntrypointsMap [uparamTypeQ| or (int %a) (nat %b) |] @?= Map.fromList [ (UnsafeEpName "a", [utypeQ| int |]) , (UnsafeEpName "b", [utypeQ| nat |]) ] , testCase "Root entrypoint is considered" $ - U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) %root |] + U.mkEntrypointsMap [uparamTypeQ| or %root (int %a) (nat %b) |] @?= Map.fromList - [ (UnsafeEpName "root", [utypeQ| (int %a | nat %b) |]) + [ (UnsafeEpName "root", [utypeQ| or (int %a) (nat %b) |]) , (UnsafeEpName "a", [utypeQ| int |]) , (UnsafeEpName "b", [utypeQ| nat |]) ] diff --git a/morley-test/Test/Ext.hs b/morley-test/Test/Ext.hs --- a/morley-test/Test/Ext.hs +++ b/morley-test/Test/Ext.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Ext ( test_PRINT_and_TEST_ASSERT @@ -11,32 +10,73 @@ import Fmt (pretty) import Test.HUnit (Assertion, assertFailure) import Test.Hspec.Expectations (shouldSatisfy) -import Test.Tasty (TestTree) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Morley.Michelson.Interpret (MorleyLogs(..), interpret) import Morley.Michelson.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter) import Morley.Michelson.TypeCheck - (HST(..), SomeHST(..), TypeCheckMode(..), runTypeCheck, throwingTCError, typeCheckExt, - typeCheckInstr, typeCheckingWith, unsafeMkSomeParamType, unsafeWithWTP) -import Morley.Michelson.Typed (epcPrimitive, pattern AsUType) -import qualified Morley.Michelson.Typed as T + (HST(..), SomeHST(..), TypeCheckMode(..), mkSomeParamType, runTypeCheck, throwingTCError, + typeCheckExt, typeCheckInstr, typeCheckingWith, unsafeWithWTP) +import Morley.Michelson.Typed (epcPrimitive, pattern (:#), pattern AsUType) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped (ExpandedExtInstr, ExtInstrAbstract(..), ParameterType(..), StackTypePattern(..), T(..), Ty(..), TyVar(..), noAnn) +import Morley.Util.PeanoNatural (PeanoNatural(..)) import Test.Cleveland.Instances () -import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract) -import Test.Util.Contracts -test_PRINT_and_TEST_ASSERT :: IO [TestTree] -test_PRINT_and_TEST_ASSERT = concatTestTrees - [ testTreesWithTypedContract (inContractsDir "testassert_square.mtz") $ - testAssertSquareImpl - , testTreesWithTypedContract (inContractsDir "testassert_square2.mtz") $ - testAssertSquareImpl +testassert_square :: T.Contract ('T.TPair 'T.TInt 'T.TInt) 'T.TUnit +testassert_square = T.defaultContract $ + T.CAR :# + T.UNPAIR :# + T.Ext (T.TEST_ASSERT + (T.TestAssert "CheckSides" + (T.PrintComment [Left "Sides are ", Right (T.StackRef Zero), Left " x ", Right (T.StackRef One)]) + ( T.DUP :# + T.GT :# + T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT) :# + T.DIPN Two (T.DUP :# T.GT :# T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT)) :# + T.AND :# T.AND :# T.AND + ) + )) :# + T.MUL :# + T.Ext (T.PRINT $ T.PrintComment [Left "Area is ", Right $ T.StackRef Zero]) :# + T.DROP :# + T.UNIT :# + T.NIL @'T.TOperation :# + T.PAIR + +-- | This is like 'testassert_square', but test_assert is executed on stack +-- with more than one element. +testassert_square2 :: T.Contract ('T.TPair 'T.TInt 'T.TInt) 'T.TUnit +testassert_square2 = T.defaultContract $ + T.CAR :# + T.DIP T.UNIT :# + T.UNPAIR :# + T.Ext (T.TEST_ASSERT + (T.TestAssert "CheckSides" + (T.PrintComment [Left "Sides are ", Right (T.StackRef Zero), Left " x ", Right (T.StackRef One)]) + ( T.DUP :# + T.GT :# + T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT) :# + T.DIPN Two (T.DUP :# T.GT :# T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT)) :# + T.AND :# T.AND :# T.AND + ) + )) :# + T.MUL :# + T.Ext (T.PRINT $ T.PrintComment [Left "Area is ", Right $ T.StackRef Zero]) :# + T.DROP :# + T.NIL @'T.TOperation :# + T.PAIR + +test_PRINT_and_TEST_ASSERT :: [TestTree] +test_PRINT_and_TEST_ASSERT = + [ testGroup "testassert_square" $ testAssertSquareImpl testassert_square + , testGroup "testassert_square2" $ testAssertSquareImpl testassert_square2 ] where - testAssertSquareImpl c = pure + testAssertSquareImpl c = [ testCase "TEST_ASSERT assertion passed" $ do runTest True c 100 100 runTest True c 1 1 @@ -103,7 +143,7 @@ nh (ni, si) = typeCheckingWith def $ runTypeCheck (TypeCheckContract $ - unsafeMkSomeParamType $ + unsafe . mkSomeParamType $ ParameterType (Ty TKey noAnn) noAnn) (usingReaderT def $ throwingTCError $ @@ -112,5 +152,5 @@ runExtTest :: (ExpandedExtInstr, SomeHST) -> Bool -> Assertion runExtTest (ui, SomeHST hst) correct = case (nh (ui, hst), correct) of (Right _, False) -> assertFailure $ "Test expected to fail but it passed" - (Left e, True) -> assertFailure $ "Test expected to pass but it failed with error: " <> show e + (Left e, True) -> assertFailure $ "Test expected to pass but it failed with error: " <> pretty e _ -> pass diff --git a/morley-test/Test/Import.hs b/morley-test/Test/Import.hs --- a/morley-test/Test/Import.hs +++ b/morley-test/Test/Import.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE QuasiQuotes #-} @@ -24,7 +23,7 @@ import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos) import Morley.Michelson.Parser (codeSrc) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Util.Interpolate import Test.Cleveland hiding (importContract, importUntypedContract) import Test.Cleveland.Instances () diff --git a/morley-test/Test/Integrational.hs b/morley-test/Test/Integrational.hs --- a/morley-test/Test/Integrational.hs +++ b/morley-test/Test/Integrational.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for integrational testing machinery. module Test.Integrational diff --git a/morley-test/Test/Interpreter.hs b/morley-test/Test/Interpreter.hs --- a/morley-test/Test/Interpreter.hs +++ b/morley-test/Test/Interpreter.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Interpreter @@ -9,7 +11,7 @@ , test_increment , test_fail , test_mutez_add_overflow - , test_mutez_sub_overflow + , test_mutez_sub_underflow , test_basic1 , test_lsl , test_lsr @@ -29,34 +31,29 @@ , test_fail_callstack ) where -import Fmt (Buildable(..), (+|), (|+)) +import Fmt ((+|), (|+)) import Hedgehog (forAll, property) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) -import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage, NiceUnpackedValue) +import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage) import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), srcPos) import Morley.Michelson.Text import Morley.Michelson.Typed (IsoValue(..), divMich, modMich) -import qualified Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Crypto import Test.Cleveland import Test.Cleveland.Internal.Abstract (TransferFailure(..), TransferFailureReason(..)) -import Test.Cleveland.Michelson - (concatTestTrees, testTreesWithTypedContract, testTreesWithUntypedContract) +import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract) +import Test.Cleveland.Michelson.Import + (testTreesWithTypedContractExt, testTreesWithUntypedContractExt) import Test.Util.Contracts -instance Buildable ByteString where - build = show - -instance Buildable Tuple1 where - build = show - catchTransferFailureReason :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailureReason catchTransferFailureReason = fmap tfReason . catchTransferFailure @@ -67,7 +64,6 @@ , HasEntrypointArg cp (EntrypointRef 'Nothing) cp , AsRPC st ~ st , NiceParameterFull cp, NiceStorage st - , NiceUnpackedValue (AsRPC st) ) => AliasHint -> T.Contract (ToT cp) (ToT st) -> cp -> st -> m st callSimple nm contract cp st = do @@ -124,14 +120,11 @@ _ -> failure "expecting another failure reason" ] -test_mutez_sub_overflow :: IO [TestTree] -test_mutez_sub_overflow = +test_mutez_sub_underflow :: IO [TestTree] +test_mutez_sub_underflow = testTreesWithTypedContract (contractsDir "mutez_sub_underflow.tz") $ \contract -> pure [ testScenarioOnEmulator "Mutez sub underflow test" $ scenario $ callSimple "mutez_sub_underflow" contract () () - & catchTransferFailureReason >>= \case - MutezArithError T.SubUnderflow -> pass - x -> failure $ "expecting another failure reason, got " +| x |+ "" ] test_basic1 :: IO [TestTree] @@ -200,7 +193,7 @@ test_fail_callstack :: IO [TestTree] test_fail_callstack = - testTreesWithUntypedContract (contractsDir "fail_in_let.mtz") $ \contract -> pure + testTreesWithUntypedContractExt (contractsDir "fail_in_let.mtz") $ \contract -> pure [ testScenarioOnEmulator "Should correctly report FAIL instruction position" $ scenario do callUntyped "fail_in_let" contract True () & catchTransferFailureReason >>= \case FailedWith _ (Just ics) -> @@ -225,7 +218,7 @@ test_Sum_types :: IO [TestTree] test_Sum_types = concatTestTrees - [ testTreesWithUntypedContract (contractsDir "union.mtz") $ \contract -> pure + [ testTreesWithUntypedContractExt (contractsDir "union.mtz") $ \contract -> pure [ testGroup "union.mtz: union corresponds to Haskell types properly" $ let caseTest param = scenario $ callUntyped "union" contract param () in @@ -236,7 +229,7 @@ , testScenarioOnEmulator "Case 5" $ caseTest (Case5 ["q"]) ] ] - , testTreesWithUntypedContract (contractsDir "case.mtz") $ \contract -> pure + , testTreesWithUntypedContractExt (contractsDir "case.mtz") $ \contract -> pure [ testGroup "CASE instruction" $ let caseTest param expectedStorage = scenario $ callUntyped "case" contract param ("" :: MText) @@ -249,7 +242,7 @@ , testScenarioOnEmulator "Case 5" $ caseTest (Case5 $ ["a", "b"]) "ab" ] ] - , testTreesWithTypedContract (contractsDir "tag.mtz") $ \contract -> pure + , testTreesWithTypedContractExt (contractsDir "tag.mtz") $ \contract -> pure [ testScenarioOnEmulator "TAG instruction" $ scenario $ let expected = mconcat ["unit" :: MText, "o" :: MText, "ab" :: MText, "nat" :: MText, "int" :: MText] in callSimple "tag" contract () ("" :: MText) @@== expected @@ -258,17 +251,17 @@ test_Product_types :: IO [TestTree] test_Product_types = concatTestTrees - [ testTreesWithTypedContract (contractsDir "access.mtz") $ \contract -> pure + [ testTreesWithTypedContractExt (contractsDir "access.mtz") $ \contract -> pure [ testScenarioOnEmulator "ACCESS instruction" $ scenario $ callSimple @Tuple1 "access" contract (1, "a", Just "a", Right "a", ["a"]) () ] - , testTreesWithTypedContract (contractsDir "set.mtz") $ \contract -> pure + , testTreesWithTypedContractExt (contractsDir "set.mtz") $ \contract -> pure [ testScenarioOnEmulator "SET instruction" $ scenario $ let expected = (2, "za", Just "wa", Right "ya", ["ab"]) :: Tuple1 in callSimple @_ @Tuple1 "set" contract () (1, "a", Just "a", Right "a", ["a", "b"]) @@== expected ] - , testTreesWithTypedContract (contractsDir "construct.mtz") $ \contract -> pure + , testTreesWithTypedContractExt (contractsDir "construct.mtz") $ \contract -> pure [ testScenarioOnEmulator "CONSTRUCT instruction" $ scenario $ let expected = (1, "a", Just "b", Left "q", []) :: Tuple1 in callSimple @_ @Tuple1 "construct" contract () (0, "", Nothing, Right "", []) @@== expected diff --git a/morley-test/Test/Interpreter/Annotations.hs b/morley-test/Test/Interpreter/Annotations.hs --- a/morley-test/Test/Interpreter/Annotations.hs +++ b/morley-test/Test/Interpreter/Annotations.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Interpreter.Annotations ( test_cast_notes @@ -23,12 +22,14 @@ , test_special_annotations ) where +import Debug qualified (show) import Prelude hiding (Const) +import Unsafe qualified import Control.Lens (ix, makeLensesFor, (<<%=)) import Control.Monad.RWS.Strict (RWST, runRWST) -import qualified Data.List as List -import Data.Map.Strict as Map +import Data.List qualified as List +import Data.Map.Strict qualified as Map import Data.Vinyl (Rec(..)) import Data.Vinyl.Functor (Const(..)) import Data.Vinyl.Recursive (recordToList, rmap) @@ -41,20 +42,19 @@ (ContractEnv, InstrRunner, InterpreterState(..), InterpreterStateMonad(..), MichelsonFailureWithStack(..), MorleyLogsBuilder, StkEl(..), initInterpreterState, mkInitStack, runInstrImpl, starNotesStkEl) +import Morley.Michelson.Parser (notes) import Morley.Michelson.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed (Notes(..), Operation, Value'(..), starNotes, starParamNotes, toVal) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped (noAnn) -import qualified Morley.Michelson.Untyped as U -import Morley.Tezos.Address (Address, unsafeParseAddress) -import Morley.Tezos.Core (toMutez) +import Morley.Michelson.Untyped qualified as U +import Morley.Tezos.Address (Address, parseAddress) import Morley.Util.Sing (eqParamSing) import Test.Cleveland.Instances () import Test.Cleveland.Michelson (importContract) -import qualified Text.Show -import qualified Unsafe +import Text.Show qualified import Test.Util.Contracts (contractsDir, ()) @@ -72,7 +72,7 @@ instance Show SomeStack where show (SomeStack v) = case v of RNil -> "[]" - x :& xs -> show x <> " :& " <> show (SomeStack xs) + x :& xs -> Debug.show x <> " :& " <> Debug.show (SomeStack xs) instance Eq SomeStack where a == b = stackToElems a == stackToElems b @@ -102,10 +102,10 @@ type TestInstrRunner = InstrRunner (ExceptT MichelsonFailureWithStack $ RWST ContractEnv MorleyLogsBuilder TestInterpreterState IO) -runInstrTest :: TestInstrRunner +runInstrTest :: HasCallStack => TestInstrRunner runInstrTest = runInstrTestImpl False -runInstrTestImpl :: Bool -> TestInstrRunner +runInstrTestImpl :: HasCallStack => Bool -> TestInstrRunner runInstrTestImpl skipInstr instr stack = do actualStack <- runInstrImpl (runInstrTestImpl $ isAnnotated instr) instr stack when (isRealInstr instr && not skipInstr) do @@ -144,7 +144,8 @@ _ -> True stackAnnotationsTest - :: String + :: HasCallStack + => String -> Rec StkEl (T.ContractInp cp st) -> [Maybe SomeStack] -> T.Contract cp st @@ -154,7 +155,8 @@ stackAnnotationsAssertion initialStack expectedStacks contract stackAnnotationsAssertion - :: Rec StkEl (T.ContractInp cp st) + :: HasCallStack + => Rec StkEl (T.ContractInp cp st) -> [Maybe SomeStack] -> T.Contract cp st -> Assertion @@ -217,14 +219,14 @@ ] where y :: T.Notes 'T.TInt - y = T.NTInt "y" + y = [notes|int :y|] param = "parameter" expectedStacksIF_NONE_None :: [Maybe SomeStack] expectedStacksIF_NONE_None = [ -- CAR - someStack $ StkEl (T.VOption @'T.TInt Nothing) param (T.NTOption U.noAnn y) :& RNil + someStack $ StkEl (T.VOption @'T.TInt Nothing) param [notes|option (int :y)|] :& RNil -- PUSH (int :y) 0 , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil -- IF_NONE @@ -237,7 +239,7 @@ expectedStacksIF_NONE_Some :: [Maybe SomeStack] expectedStacksIF_NONE_Some = [ -- CAR - someStack $ StkEl (T.VOption $ Just $ T.VInt 6) param (T.NTOption U.noAnn y) :& RNil + someStack $ StkEl (T.VOption $ Just $ T.VInt 6) param [notes|option (int :y)|] :& RNil -- PUSH (int :y) 1 , someStack $ StkEl (T.VInt 1) U.noAnn y :& StkEl (T.VInt 6) param y :& RNil -- ADD @@ -252,7 +254,7 @@ expectedStacksIF_LEFT_Left :: [Maybe SomeStack] expectedStacksIF_LEFT_Left = [ -- CAR - someStack $ StkEl (T.VOr @'T.TInt $ Left $ T.VInt 6) param (T.NTOr U.noAnn U.noAnn U.noAnn y y) :& RNil + someStack $ StkEl (T.VOr @'T.TInt $ Left $ T.VInt 6) param [notes|or (int :y) (int :y)|] :& RNil -- PUSH (int :y) 1 , someStack $ StkEl (T.VInt 1) U.noAnn y :& StkEl (T.VInt 6) param y :& RNil -- ADD @@ -267,7 +269,7 @@ expectedStacksIF_LEFT_Right :: [Maybe SomeStack] expectedStacksIF_LEFT_Right = [ -- CAR - someStack $ StkEl (T.VOr @'T.TInt $ Right $ T.VInt 7) param (T.NTOr U.noAnn U.noAnn U.noAnn y y) :& RNil + someStack $ StkEl (T.VOr @'T.TInt $ Right $ T.VInt 7) param [notes|or (int :y) (int :y)|] :& RNil -- PUSH (int :y) 2 , someStack $ StkEl (T.VInt 2) U.noAnn y :& StkEl (T.VInt 7) param y :& RNil -- ADD @@ -282,7 +284,7 @@ expectedStacksIF_CONS_Cons :: [Maybe SomeStack] expectedStacksIF_CONS_Cons = [ -- CAR - someStack $ StkEl (T.VList [T.VInt 10]) param (T.NTList U.noAnn y) :& RNil + someStack $ StkEl (T.VList [T.VInt 10]) param [notes|list (int :y)|] :& RNil -- DROP , someStack $ RNil -- DIP @@ -299,7 +301,7 @@ expectedStacksIF_CONS_Nil :: [Maybe SomeStack] expectedStacksIF_CONS_Nil = [ -- CAR - someStack $ StkEl (T.VList @'T.TInt []) param (T.NTList U.noAnn y) :& RNil + someStack $ StkEl (T.VList @'T.TInt []) param [notes|list (int :y)|] :& RNil -- PUSH (int :y) 0 , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil -- IF_CONS @@ -319,8 +321,7 @@ ] where notesPair :: T.Notes ('T.TPair 'T.TInt 'T.TInt) - notesPair = - T.NTPair "q" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "x") (T.NTInt "y") + notesPair = [notes|pair :q (int :x) (int :y)|] pair :: T.Value ('T.TPair 'T.TInt 'T.TInt) pair = T.VPair (T.VInt 1, T.VInt 2) @@ -333,7 +334,7 @@ , someStack $ StkEl pair "ab" - (T.NTPair "p" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "a") (T.NTInt "b")) :& RNil + [notes|pair :p (int :a) (int :b)|] :& RNil -- CAST (pair int int) , someStack $ StkEl pair "ab" T.starNotes :& RNil -- CAST @xy (pair (int :x) (int :y)) @@ -359,7 +360,7 @@ ] where q :: T.Notes 'T.TInt - q = T.NTInt "q" + q = [notes|int :q|] qv :: U.VarAnn qv = "q" @@ -412,17 +413,11 @@ ] y :: T.Notes 'T.TInt - y = T.NTInt "y" + y = [notes|int :y|] yv :: U.VarAnn yv = "y" - list :: T.Notes ('T.TList 'T.TInt) - list = T.NTList "list" T.starNotes - - listv :: U.VarAnn - listv = "list" - expectedStacksMap :: [Maybe SomeStack] expectedStacksMap = [ -- DROP @@ -430,7 +425,7 @@ -- PUSH @y (int :y) 42 , someStack $ StkEl (T.VInt 42) yv y :& RNil -- PUSH @list (list :l int) {1; 10} - , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) listv list :& StkEl (T.VInt 42) yv y :& RNil + , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) "list" [notes|list :list int|] :& StkEl (T.VInt 42) yv y :& RNil -- CAST @q (int :q) , someStack $ StkEl (T.VInt 1) qv q :& StkEl (T.VInt 42) yv y :& RNil -- CAST int @@ -444,7 +439,7 @@ -- DIP , someStack $ StkEl (T.VInt 10) qv q :& StkEl (T.VInt 42) yv T.starNotes :& RNil -- MAP - , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) U.noAnn (T.NTList U.noAnn q) :& StkEl (T.VInt 42) yv T.starNotes :& RNil + , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) U.noAnn [notes|list (int :q)|] :& StkEl (T.VInt 42) yv T.starNotes :& RNil -- DROP , someStack $ StkEl (T.VInt 42) yv T.starNotes :& RNil -- NIL operation @@ -463,13 +458,13 @@ ] where m :: T.Notes ('T.TMap 'T.TInt 'T.TInt) - m = T.NTMap "m" k (T.NTInt "v") + m = [notes|map :m (int :k) (int :v)|] k :: T.Notes 'T.TInt - k = T.NTInt "k" + k = [notes|int :k|] v :: T.Notes ('T.TOption 'T.TInt) - v = T.NTOption U.noAnn $ T.NTInt "v" + v = [notes|option (int :v)|] mv, kv, vv :: U.VarAnn mv = "m" @@ -510,7 +505,7 @@ ] where address :: Address - address = unsafeParseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD" + address = unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD" storage :: T.Value 'T.TAddress storage = T.VAddress $ T.EpAddress address T.DefEpName @@ -519,13 +514,13 @@ op = T.VOption Nothing mutez :: T.Value 'T.TMutez - mutez = T.VMutez $ toMutez 100 + mutez = T.VMutez 100 contract :: T.Value 'T.TOperation contract = T.VOp $ T.OpCreateContract T.CreateContract { T.ccOriginator = genesisAddress , T.ccDelegate = Nothing - , T.ccBalance = toMutez 100 + , T.ccBalance = 100 , T.ccStorageVal = T.VUnit , T.ccContract = T.defaultContract $ let loc c = T.WithLoc $ InstrCallStack [] $ srcPos 12 c in @@ -565,19 +560,9 @@ expectedStacks contract where - pairNotes = - NTPair noAnn - "aa" noAnn - noAnn noAnn - (NTInt "a") - (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c")) + pairNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] - pairNotes' = - NTPair noAnn - noAnn noAnn - noAnn noAnn - (NTInt "a") - (NTPair noAnn noAnn noAnn noAnn noAnn (NTInt "b") (NTInt "c")) + pairNotes' = [notes|pair (int :a) (int :b) (int :c)|] paramN = "parameter" @@ -598,9 +583,9 @@ RNil -- UNPAIR 3 , someStack $ - StkEl (toVal @Integer 4) "aa" (NTInt "a") :& - StkEl (toVal @Integer 5) "bb" (NTInt "b") :& - StkEl (toVal @Integer 6) "cc" (NTInt "c") :& + StkEl (toVal @Integer 4) "aa" [notes|int :a|] :& + StkEl (toVal @Integer 5) "bb" [notes|int :b|] :& + StkEl (toVal @Integer 6) "cc" [notes|int :c|] :& RNil -- PAIR @newStorage 3; , someStack $ @@ -628,15 +613,9 @@ expectedStacks contract where - paramNotes = - NTPair noAnn - "aa" noAnn - noAnn noAnn - (NTInt "a") - (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c")) + paramNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] - storageNotes = - NTPair noAnn "aa" "bb" noAnn noAnn (NTInt "a") (NTInt "b") + storageNotes = [notes|pair (int :a %aa) (int :b %bb)|] storage = (5, 6) :: (Integer, Integer) param = (1, (2, 3)) :: (Integer, (Integer, Integer)) @@ -658,18 +637,18 @@ RNil -- GET 3; , someStack $ - StkEl (toVal @Integer 2) noAnn (NTInt "b") :& + StkEl (toVal @Integer 2) noAnn [notes|int :b|] :& StkEl (toVal param) "parameter" paramNotes :& RNil -- SWAP; , someStack $ StkEl (toVal param) "parameter" paramNotes :& - StkEl (toVal @Integer 2) noAnn (NTInt "b") :& + StkEl (toVal @Integer 2) noAnn [notes|int :b|] :& RNil -- GET @aa 1 , someStack $ - StkEl (toVal @Integer 1) "aa" (NTInt "a") :& - StkEl (toVal @Integer 2) noAnn (NTInt "b") :& + StkEl (toVal @Integer 1) "aa" [notes|int :a|] :& + StkEl (toVal @Integer 2) noAnn [notes|int :b|] :& RNil -- PAIR 2 -- NIL operation; @@ -691,11 +670,11 @@ ignoreStack -- PUSH @var (int :i) 1 , someStack $ - StkEl (toVal @Integer 1) "var" (NTInt "i") :& + StkEl (toVal @Integer 1) "var" [notes|int :i|] :& RNil -- GET 0; , someStack $ - StkEl (toVal @Integer 1) noAnn (NTInt "i") :& + StkEl (toVal @Integer 1) noAnn [notes|int :i|] :& RNil -- NIL operation; -- PAIR 2; @@ -714,12 +693,12 @@ expectedStacks = [ -- DROP ignoreStack - -- PUSH (pair (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) (Pair 0 "a" Unit); + -- PUSH (pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) { 0; "a"; Unit }; , someStack $ StkEl (toVal (0 :: Integer, ("a" :: MText, ()))) noAnn - (NTPair "t0" "f1" "" "" "" (NTInt "t1") (NTPair "" "f2" "f3" "" "" (NTString "t2") (NTUnit "t3"))) :& + [notes|(pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3))|] :& RNil -- PUSH (nat :t4) 0; UPDATE 1; @@ -732,7 +711,7 @@ StkEl (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural))) noAnn - (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f2" "f3" "" "" (NTNat "t5") (NTNat "t6"))) :& + [notes|(pair :t0 (nat :t4 %f1) (nat :t5 %f2) (nat :t6 %f3))|] :& RNil -- PUSH (pair (nat :t7 %f7) (nat :t8 %f8)) (Pair 0 0); @@ -742,7 +721,7 @@ StkEl (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural))) noAnn - (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f7" "f8" "" "" (NTNat "t7") (NTNat "t8"))) :& + [notes|pair :t0 (nat :t4 %f1) (nat :t7 %f7) (nat :t8 %f8)|] :& RNil -- PUSH (nat :t9) 0; @@ -752,7 +731,7 @@ StkEl (toVal (0 :: Natural, 0 :: Natural)) noAnn - (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTNat "t9")) :& + [notes|pair :t0 (nat :t4 %f1) (nat :t9)|] :& RNil -- NIL operation; PAIR; , ignoreStack, ignoreStack @@ -811,16 +790,16 @@ -- GET_AND_UPDATE , someStack $ - StkEl (toVal (Nothing :: Maybe Natural)) "varVal" (NTOption "" (NTNat "v")) :& - StkEl (toVal (one (1, 1) :: Map Integer Natural)) "varMap" (NTMap "map" (NTInt "k") (NTNat "v")) :& + StkEl (toVal (Nothing :: Maybe Natural)) "varVal" [notes|option (nat :v)|] :& + StkEl (toVal (one (1, 1) :: Map Integer Natural)) "varMap" [notes|map :map (int :k) (nat :v)|] :& RNil -- PUSH @varKey (int :k) 1; -- GET_AND_UPDATE @newVarMap; , ignoreStack , someStack $ - StkEl (toVal (Just 1 :: Maybe Natural)) "varVal" (NTOption "" (NTNat "v")) :& - StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" (NTMap "map" (NTInt "k") (NTNat "v")) :& + StkEl (toVal (Just 1 :: Maybe Natural)) "varVal" [notes|option (nat :v)|] :& + StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" [notes|map :map (int :k) (nat :v)|] :& RNil -- DROP 2; @@ -832,14 +811,14 @@ test_dupn = importContract (contractsDir "dup-n.tz") <&> stackAnnotationsTest "Check that annotations behave as intended with DUP n (#471)" - (StkEl (T.VPair (T.VUnit, store)) noAnn (NTPair noAnn noAnn noAnn noAnn noAnn starNotes x) :& RNil) + (StkEl (T.VPair (T.VUnit, store)) noAnn [notes|pair unit (int :x)|] :& RNil) expectedStacks where store :: T.Value 'T.TInt store = T.VInt 42 x :: T.Notes 'T.TInt - x = T.NTInt "x" + x = [notes|int :x|] kek :: T.Value 'T.TString kek = T.VString "kek" @@ -929,7 +908,7 @@ contract where param = (1, 2, ()) :: (Natural, Natural, ()) - paramNotes = NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTUnit "last")) + paramNotes = [notes|pair nat nat (unit :last)|] expectedStacks :: [Maybe SomeStack] expectedStacks = @@ -958,9 +937,9 @@ -- DROP , ignoreStack -- GET @kek 4 - , someStack $ StkEl VUnit "kek" (NTUnit "last") :& RNil + , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil -- CDR @kek 2 (macro expanded above) - , someStack $ StkEl VUnit "kek" (NTUnit "last") :& RNil + , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil -- NIL operation , ignoreStack -- PAIR @@ -1065,9 +1044,9 @@ expectedStacksRIGHTSpecial :: [Maybe SomeStack] expectedStacksRIGHTSpecial = [ -- CAR - someStack $ StkEl (VUnit) "p.y" (NTUnit noAnn) :& RNil + someStack $ StkEl (VUnit) "p.y" starNotes :& RNil -- RIGHT % %@ never - , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" (NTOr noAnn noAnn "y" (NTNever "") (NTUnit "")) :& RNil + , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" [notes|or never (unit %y)|] :& RNil -- DROP -- PUSH unit Unit -- NUL operation diff --git a/morley-test/Test/Interpreter/Apply.hs b/morley-test/Test/Interpreter/Apply.hs --- a/morley-test/Test/Interpreter/Apply.hs +++ b/morley-test/Test/Interpreter/Apply.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -12,11 +11,10 @@ import Test.Tasty (TestTree) -import Fmt (Buildable(..)) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Test.Cleveland -import Test.Cleveland.Util (unsafeFromHex) +import Test.Cleveland.Util (fromHex) import Test.Util.Contracts @@ -40,13 +38,10 @@ partApplyContract <- importUntypedContract $ inContractsDir "partially-applied-lambda-packed.tz" handle <- originateUntypedSimple "apply" (U.ValueBytes $ U.InternalByteString "") partApplyContract - let expected = unsafeFromHex "05020000000f0743035b0005034202000000020316" + let expected = unsafe $ fromHex "05020000000f0743035b0005034202000000020316" transfer TransferData { tdTo = handle , tdAmount = 0 , tdEntrypoint = DefEpName , tdParameter = () } getStorage @ByteString handle @@== expected - -instance Buildable ByteString where - build = show diff --git a/morley-test/Test/Interpreter/Auction.hs b/morley-test/Test/Interpreter/Auction.hs --- a/morley-test/Test/Interpreter/Auction.hs +++ b/morley-test/Test/Interpreter/Auction.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module, containing spec to test auction.tz contract. -- @@ -10,15 +9,15 @@ ) where import Hedgehog (forAll, property, withTests) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen.Tezos.Core (genMutez', genTimestamp, midTimestamp) import Hedgehog.Gen.Tezos.Crypto (genKeyHash) import Morley.Tezos.Address (Address(..)) -import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, toMutez, unMutez, unsafeMkMutez) +import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds) import Morley.Tezos.Crypto (KeyHash, hashKey) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract) @@ -37,7 +36,7 @@ test_Auction = [ testScenarioOnEmulator "Bid after end of auction triggers failure" $ withInitialNow midTimestamp $ scenario do - let initState = (aBitBeforeMidTimestamp, (toMutez 1000, keyHash1)) + let initState = (aBitBeforeMidTimestamp, (1000, keyHash1)) handle <- originateSimple @Param @Storage "auction" initState contract transfer TransferData { tdTo = handle @@ -88,9 +87,8 @@ -- ^ 1s before NOW denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4 - denseAmount = unsafeMkMutez <$> Gen.word64 (Range.constant (midAmount' - 4) (midAmount' + 4)) + denseAmount = genMutez' $ Range.constant (midAmount - 4) (midAmount + 4) midAmount = maxMutez `div` 2 - midAmount' = unMutez midAmount genMutez'' = genMutez' $ Range.constant 0 maxMutez maxMutez = maxBound `div` 100 @@ -130,7 +128,7 @@ = assert (isLeft resE) "Failure didn't trigger on attempt to bid with amount <= than previous bid" | Left e <- resE - = failure $ "Unexpected script fail: " <> show e + = failure $ "Unexpected script fail: " <> fromString (displayException e) | Right (endOfAuction', _) <- resE , endOfAuction /= endOfAuction' @@ -144,6 +142,5 @@ , keyHash' /= newKeyHash = failure $ "Storage updated to wrong value: new key hash" <> " is not equal to contract's parameter" - | Right _ <- resE = getBalance addr @@== amount diff --git a/morley-test/Test/Interpreter/Balance.hs b/morley-test/Test/Interpreter/Balance.hs --- a/morley-test/Test/Interpreter/Balance.hs +++ b/morley-test/Test/Interpreter/Balance.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Interpreter.Balance ( test_balanceIncludesAmount @@ -8,12 +7,12 @@ ) where import Hedgehog (Gen, forAll, property, withTests) -import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core import Test.Cleveland import Test.Cleveland.Michelson (testTreesWithUntypedContract) @@ -28,8 +27,8 @@ genFixture :: Gen Fixture genFixture = do - fStartingBalance <- toMutez <$> Gen.enum 1000 5000 - fAmount <- toMutez <$> Gen.enum 0 1000 + fStartingBalance <- Gen.enum 1000 5000 + fAmount <- Gen.enum 0 1000 return Fixture{..} test_balanceIncludesAmount :: IO [TestTree] @@ -77,14 +76,14 @@ let origDataA = UntypedOriginateData { uodName = "balance_test_case_a" - , uodBalance = (toMutez 0) + , uodBalance = 0 , uodStorage = (untypeValue $ toVal @[Mutez] []) , uodContract = contractA } let origDataB = UntypedOriginateData { uodName = "balance_test_case_b" - , uodBalance = (toMutez 0) + , uodBalance = 0 , uodStorage = (untypeValue $ toVal ()) , uodContract = contractB } @@ -93,7 +92,7 @@ let transferData = TransferData { tdTo = addressA - , tdAmount = toMutez 100 + , tdAmount = 100 , tdEntrypoint = DefEpName , tdParameter = addressB } @@ -102,6 +101,6 @@ -- A sends 30 to B, then B sends 5 back to A. A records call to BALANCE at each entry. -- We expect that 5 mutez sent back are included in the second call to BALANCE. - let expectedStorage = [toMutez 75, toMutez 100] + let expectedStorage = [75, 100] getStorage @[Mutez] addressA @@== expectedStorage ] diff --git a/morley-test/Test/Interpreter/CallSelf.hs b/morley-test/Test/Interpreter/CallSelf.hs --- a/morley-test/Test/Interpreter/CallSelf.hs +++ b/morley-test/Test/Interpreter/CallSelf.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for the contract that calls self several times. @@ -11,16 +10,16 @@ ) where import Hedgehog (forAll, property, withTests) -import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen qualified as Gen import Test.HUnit (Assertion, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) import Test.Tasty.Hedgehog (testProperty) -import qualified Unsafe (fromIntegral) +import Unsafe qualified (fromIntegral) import Morley.Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Test.Cleveland import Test.Cleveland.Michelson (ContractPropValidator, contractProp) import Test.Cleveland.Michelson.Dummy diff --git a/morley-test/Test/Interpreter/CallSelfAddress.hs b/morley-test/Test/Interpreter/CallSelfAddress.hs --- a/morley-test/Test/Interpreter/CallSelfAddress.hs +++ b/morley-test/Test/Interpreter/CallSelfAddress.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Interpreter.CallSelfAddress ( test_Call_self_address diff --git a/morley-test/Test/Interpreter/ComparableSet.hs b/morley-test/Test/Interpreter/ComparableSet.hs --- a/morley-test/Test/Interpreter/ComparableSet.hs +++ b/morley-test/Test/Interpreter/ComparableSet.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.ComparableSet @@ -9,8 +8,8 @@ import Data.Set as Set (fromList, toList) import Hedgehog (forAll, property, withTests) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) diff --git a/morley-test/Test/Interpreter/Compare.hs b/morley-test/Test/Interpreter/Compare.hs --- a/morley-test/Test/Interpreter/Compare.hs +++ b/morley-test/Test/Interpreter/Compare.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.Compare @@ -13,13 +12,12 @@ import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen.Michelson.Typed -import qualified Hedgehog.Gen.Michelson.Untyped as U +import Hedgehog.Gen.Michelson.Untyped qualified as U import Hedgehog.Gen.Tezos.Core (genMutez) import Morley.Michelson.Interpret (ContractReturn) -import Morley.Michelson.TypeCheck.Types (getWTP') import Morley.Michelson.Typed (ToT, fromVal) -import qualified Morley.Michelson.Typed as T -import Morley.Tezos.Core (Mutez, toMutez) +import Morley.Michelson.Typed qualified as T +import Morley.Tezos.Core (Mutez) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract) import Test.Cleveland.Util (failedTest, genTuple2) @@ -32,7 +30,7 @@ -- | Spec to test compare.tz contract. test_compare :: [TestTree] test_compare = - [ testScenarioOnEmulator "success test" $ myScenario (toMutez 10, toMutez 11) + [ testScenarioOnEmulator "success test" $ myScenario (10, 11) , testProperty "Random check" $ withTests 200 $ property $ do inputParam <- forAll $ genTuple2 genMutez genMutez @@ -79,7 +77,7 @@ testProperty "Eq and Ord instances on Value match" $ withDiscards 200 $ property $ do T.AsUTypeExt st _ <- forAll U.genValidType - case (T.checkComparability st, T.checkOpPresence st, getWTP' st) of + case (T.checkComparability st, T.checkOpPresence st, T.getWTP' st) of (T.CanBeCompared, T.OpAbsent, Right T.Dict) -> do value1 <- forAll $ genValue' st value2 <- forAll $ genValue' st diff --git a/morley-test/Test/Interpreter/ComparePairs.hs b/morley-test/Test/Interpreter/ComparePairs.hs --- a/morley-test/Test/Interpreter/ComparePairs.hs +++ b/morley-test/Test/Interpreter/ComparePairs.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.ComparePairs @@ -12,7 +11,7 @@ import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen.Tezos.Core (genMutez) -import Morley.Tezos.Core (Mutez, toMutez) +import Morley.Tezos.Core (Mutez) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract) import Test.Cleveland.Util (genTuple2) @@ -25,8 +24,8 @@ test_compare_pairs :: [TestTree] test_compare_pairs = [ testScenarioOnEmulator "success test" $ myScenario - ( (toMutez 10, toMutez 11) - , (toMutez 10, toMutez 12) + ( (10, 11) + , (10, 12) ) , testProperty "Random check" $ withTests 200 $ property $ do diff --git a/morley-test/Test/Interpreter/Conditionals.hs b/morley-test/Test/Interpreter/Conditionals.hs --- a/morley-test/Test/Interpreter/Conditionals.hs +++ b/morley-test/Test/Interpreter/Conditionals.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -10,8 +9,8 @@ ) where import Hedgehog (forAll, property) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) diff --git a/morley-test/Test/Interpreter/ContractOp.hs b/morley-test/Test/Interpreter/ContractOp.hs --- a/morley-test/Test/Interpreter/ContractOp.hs +++ b/morley-test/Test/Interpreter/ContractOp.hs @@ -1,12 +1,12 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module, containing spec to test contract_op.tz contract. module Test.Interpreter.ContractOp ( test_contract_op ) where +import Fmt (pretty) import Test.Tasty (TestTree) import Morley.Michelson.Untyped @@ -64,7 +64,7 @@ } msg isGood paramType = - "parameter in environment is '" <> show paramType <> "', " <> + "parameter in environment is '" <> pretty paramType <> "', " <> bool "" "but " isGood <> "contract expects '%root int :q'" intQ = ParameterType $ Ty TInt "q" diff --git a/morley-test/Test/Interpreter/CreateAndReverseOps.hs b/morley-test/Test/Interpreter/CreateAndReverseOps.hs --- a/morley-test/Test/Interpreter/CreateAndReverseOps.hs +++ b/morley-test/Test/Interpreter/CreateAndReverseOps.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'create_2_n_reverse_ops.tz' contract. @@ -34,4 +33,4 @@ stString @== "kek" someAddr :: Address -someAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" +someAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/CreateAndTransfer.hs b/morley-test/Test/Interpreter/CreateAndTransfer.hs --- a/morley-test/Test/Interpreter/CreateAndTransfer.hs +++ b/morley-test/Test/Interpreter/CreateAndTransfer.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'create_n_transfer.tz' contract. See [#643] module Test.Interpreter.CreateAndTransfer @@ -26,4 +25,4 @@ -- Address hardcoded in 'create_n_transfer.tz'. constAddr :: Address -constAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" +constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/EnvironmentSpec.hs b/morley-test/Test/Interpreter/EnvironmentSpec.hs --- a/morley-test/Test/Interpreter/EnvironmentSpec.hs +++ b/morley-test/Test/Interpreter/EnvironmentSpec.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for the 'environment.tz' contract @@ -9,14 +8,14 @@ ) where import Hedgehog (Gen, forAll, property, withTests) -import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) import Morley.Michelson.Runtime.GState import Morley.Michelson.Typed -import qualified Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core import Test.Cleveland import Test.Cleveland.Michelson.Import (embedContract) @@ -43,8 +42,8 @@ genFixture :: Gen Fixture genFixture = do fPassOriginatedAddress <- Gen.bool - fBalance <- toMutez <$> Gen.enum 1 1234 - fAmount <- toMutez <$> Gen.enum 1 42 + fBalance <- Gen.enum 1 1234 + fAmount <- Gen.enum 1 42 return Fixture {..} testImpl @@ -86,13 +85,13 @@ let balanceAfterTransfer = fBalance fixture `unsafeAddMutez` fAmount fixture if - | balanceAfterTransfer > toMutez 1000 -> + | balanceAfterTransfer > 1000 -> expectFailedWith balanceAfterTransfer $ transfer transferData | fPassOriginatedAddress fixture -> expectFailedWith environmentAddress $ transfer transferData - | fAmount fixture < toMutez 15 -> + | fAmount fixture < 15 -> expectFailedWith (fAmount fixture) $ transfer transferData | otherwise -> transfer transferData diff --git a/morley-test/Test/Interpreter/Print.hs b/morley-test/Test/Interpreter/Print.hs --- a/morley-test/Test/Interpreter/Print.hs +++ b/morley-test/Test/Interpreter/Print.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for the @PRINT@ extended command @@ -15,7 +14,7 @@ import Morley.Michelson.Interpret (MorleyLogs(..)) import Morley.Michelson.Text (MText) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Tezos.Address (Address) import Test.Cleveland diff --git a/morley-test/Test/Interpreter/Reference.hs b/morley-test/Test/Interpreter/Reference.hs --- a/morley-test/Test/Interpreter/Reference.hs +++ b/morley-test/Test/Interpreter/Reference.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Interpreter.Reference ( test_InterpreterWithReferenceImplementation @@ -17,26 +16,25 @@ import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen.Michelson.Typed (genValue) +import Morley.AsRPC (AsRPC, MaybeRPC(..), TAsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client (RunError(..), runMorleyClientM) import Morley.Client.RPC (RunCodeErrors(..)) -import Morley.Client.RPC.AsRPC (AsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client.Util as Reference (RunContractParameters(..), runContract) import Morley.Michelson.Interpret (InterpretError(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) import Morley.Michelson.Runtime as Morley import Morley.Michelson.Runtime.GState (genesisAddress) -import Morley.Michelson.TypeCheck (TypeCheckOptions(..), withWTPm) +import Morley.Michelson.TypeCheck (TypeCheckOptions(..)) import Morley.Michelson.Typed - (Contract, Contract'(..), EpAddress(..), SingT(..), SomeContract(..), SomeStorage(..), Value, - Value'(..), dfsMapValue) + (Contract, Contract'(..), EpAddress(..), SingT(..), SomeConstrainedValue(..), SomeContract(..), + SomeStorage, Value, Value'(..), dfsMapValue) import Morley.Michelson.Typed.Arith (ArithError(..), MutezArithErrorType(..)) import Morley.Michelson.Typed.Convert import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address -import Morley.Tezos.Core - (Timestamp(..), dummyChainId, getCurrentTime, toMutez, unsafeMkMutez, zeroMutez) +import Morley.Tezos.Core (Timestamp(..), dummyChainId, getCurrentTime, zeroMutez) import Morley.Tezos.Crypto import Morley.Util.Named import Morley.Util.Sing (eqI) @@ -93,6 +91,11 @@ -- ↑ We cannot predict the actual block level in a real chain. -- There is another @../../contracts/level.tz@ contract that checks that we can interpret -- the @LEVEL@ instruction, without checking its result. + , "../../contracts/sapling_annot.tz" + , "../../contracts/sapling_transaction.tz" + , "../../contracts/tezos_examples/opcodes/sapling_empty_state.tz" + -- ↑ Sapling types and instructions are supported for typechecking only and not the actual + -- implementation. ] test_Regression688 :: IO TestTree @@ -130,14 +133,10 @@ -- inputs. testProperty ("compare result with morley interpreter for " <> file) $ withTests 4 $ property $ do - -- TODO [#392]: this check have to become unnecessary - withWTPm @st $ do - withWTPm @cp $ do - - parameter <- forAll $ genValue @cp - storage <- forAll $ genValue @st + parameter <- forAll $ genValue @cp + storage <- forAll $ genValue @st - compareWithReference withEnv file contract parameter storage + compareWithReference withEnv file contract parameter storage compareWithReference :: forall cp st. (ParameterScope cp, StorageScope st) @@ -151,9 +150,9 @@ runMorleyClientM (neMorleyClientEnv env) $ Reference.runContract @cp @st RunContractParameters { rcpContract = contract - , rcpParameter = parameter - , rcpStorage = storage - , rcpBalance = unsafeMkMutez 4000000000000 + , rcpParameter = NotRPC parameter + , rcpStorage = NotRPC storage + , rcpBalance = 4000000000000 , rcpAmount = zeroMutez , rcpSender = Just genesisAddress , rcpSource = Just genesisAddress @@ -161,9 +160,9 @@ currentTimestamp <- getCurrentTime -- Reference implementation sends 0,05 tz to implicit contract for this contract let amount = if file == "../../contracts/tezos_examples/opcodes/proxy.tz" - then toMutez 50000 else minBound + then 50000 else minBound resMorley <- try @_ @ExecutorError $ silence $ - Morley.runContract (Just currentTimestamp) (Just 0) 100500 (unsafeMkMutez 4000000000000) "" + Morley.runContract (Just currentTimestamp) (Just 0) 100500 4000000000000 "" tcOptions (untypeValue storage) (convertContract contract) (TxData genesisAddress (TxUntypedParam $ untypeValue parameter) U.DefEpName amount) (#verbose :! False) @@ -218,11 +217,11 @@ -- We also don't check big_map contents or their IDs. -- -- TODO [#604]: compare big_maps' contents. -compareValues :: forall st m. (HasCallStack, MonadTest m, SingI st) => Value (AsRPC st) -> Value st -> m () +compareValues :: forall st m. (HasCallStack, MonadTest m, SingI st) => Value (TAsRPC st) -> Value st -> m () compareValues storageReference storageMorley = preprocessValue storageReference === preprocessValue (valueAsRPC storageMorley) where - preprocessValue :: Value (AsRPC st) -> Value (AsRPC st) + preprocessValue :: Value (TAsRPC st) -> Value (TAsRPC st) preprocessValue = dfsMapValue placeStubs . scrubBigMapIDs (sing @st) placeStubs :: Value t -> Value t @@ -237,7 +236,7 @@ -- -- The morley interpreter and the RPC might assign different IDs to each big_map, -- so we need to scrub all IDs before checking whether the two storages are equivalent. - scrubBigMapIDs :: forall t. Sing t -> Value (AsRPC t) -> Value (AsRPC t) + scrubBigMapIDs :: forall t. Sing t -> Value (TAsRPC t) -> Value (TAsRPC t) scrubBigMapIDs storageSing storage = case (storageSing, storage) of (STBigMap{}, VNat _) -> VNat 0 @@ -285,13 +284,6 @@ ScriptOverflow -> True _ -> False ) $ "Morley interpreter failed with mutez multiplication overflow, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - MutezArithError SubUnderflow _ _ -> - assertRpcErrs errs - (\case - MutezSubtractionUnderflow {} -> True - _ -> False - ) $ "Morley interpreter failed with mutez subtraction underflow, \ \however reference interpreter failed with:\n" <> displayException rpcErr MichelsonGasExhaustion -> assertRpcErrs errs diff --git a/morley-test/Test/Interpreter/SetDelegate.hs b/morley-test/Test/Interpreter/SetDelegate.hs --- a/morley-test/Test/Interpreter/SetDelegate.hs +++ b/morley-test/Test/Interpreter/SetDelegate.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'create_n_transfer.tz' contract. See [#643] module Test.Interpreter.SetDelegate diff --git a/morley-test/Test/Interpreter/StackRef.hs b/morley-test/Test/Interpreter/StackRef.hs --- a/morley-test/Test/Interpreter/StackRef.hs +++ b/morley-test/Test/Interpreter/StackRef.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Interpreter tests involving 'StackRef'. diff --git a/morley-test/Test/Interpreter/StringCaller.hs b/morley-test/Test/Interpreter/StringCaller.hs --- a/morley-test/Test/Interpreter/StringCaller.hs +++ b/morley-test/Test/Interpreter/StringCaller.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for the 'string_caller.tz' contract and its interaction with -- the 'fail_or_store_and_transfer.tz' contract. Both of them have comments describing diff --git a/morley-test/Test/Interpreter/TransferAndCreate.hs b/morley-test/Test/Interpreter/TransferAndCreate.hs --- a/morley-test/Test/Interpreter/TransferAndCreate.hs +++ b/morley-test/Test/Interpreter/TransferAndCreate.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'transfer_n_create.tz' contract. See [#643] module Test.Interpreter.TransferAndCreate @@ -30,4 +29,4 @@ -- Address hardcoded in 'transfer_n_create.tz'. constAddr :: Address -constAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" +constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/Views.hs b/morley-test/Test/Interpreter/Views.hs --- a/morley-test/Test/Interpreter/Views.hs +++ b/morley-test/Test/Interpreter/Views.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on on-chain views. module Test.Interpreter.Views @@ -53,7 +52,7 @@ ] where checkContract - :: (NiceStorage st, NicePackedValue st, Eq st, Buildable st, AsRPC st ~ st) + :: (NiceStorage st, Eq st, Buildable st, AsRPC st ~ st) => String -> st -> st -> TestTree checkContract fileName initSt expected = testScenario fileName $ scenario $ clarifyErrors ("For '" +| fileName |+ "'") do diff --git a/morley-test/Test/Macro.hs b/morley-test/Test/Macro.hs --- a/morley-test/Test/Macro.hs +++ b/morley-test/Test/Macro.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Macro ( unit_PAPAIR @@ -15,9 +14,9 @@ ) where import Hedgehog (forAll, property, (===)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Gen.Michelson.Untyped as Gen.U -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Gen.Michelson.Untyped qualified as Gen.U +import Hedgehog.Range qualified as Range import Test.Hspec (Expectation, shouldBe) import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) @@ -25,7 +24,7 @@ import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), SrcPos, srcPos) import Morley.Michelson.Macro import Morley.Michelson.Untyped - (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), noAnn, unsafeMkAnnotation) + (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), mkAnnotation, noAnn) import Test.Cleveland.Instances () @@ -153,10 +152,10 @@ mapPairLeaves annotations (P pair pair) `shouldBe` P (P (leaf "field1") (leaf "field2")) (P (leaf "field3") (F n)) where - annotations = unsafeMkAnnotation <$> ["field1", "field2", "field3"] + annotations = unsafe . mkAnnotation <$> ["field1", "field2", "field3"] n = noAnn f = "field" - leaf f' = F (unsafeMkAnnotation f') + leaf f' = F (unsafe . mkAnnotation $ f') pair = P (F n) (F n) unit_expand :: Expectation diff --git a/morley-test/Test/Michelson/Parser/Value.hs b/morley-test/Test/Michelson/Parser/Value.hs --- a/morley-test/Test/Michelson/Parser/Value.hs +++ b/morley-test/Test/Michelson/Parser/Value.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Michelson.Parser.Value ( test_exponentialBacktracking @@ -18,7 +17,7 @@ test_exponentialBacktracking :: TestTree test_exponentialBacktracking = localOption (mkTimeout $ 500 * millisec) $ testCase "Parser is able to parse nested pairs in reasonable time" do - let parsedValue = P.parseNoEnv P.value "" "Pair 0 (Pair 1 (Pair 2 (Pair 3 \ + let parsedValue = P.parseNoEnv @() P.value "" "Pair 0 (Pair 1 (Pair 2 (Pair 3 \ \(Pair 4 (Pair 5 (Pair 6 (Pair 7 (Pair 8 (Pair 9 (Pair 10 (Pair 11 \ \(Pair 12 (Pair 13 (Pair 14 (Pair 15 16)))))))))))))))" expected = foldr1 ValuePair $ ValueInt <$> 0 :| [1..16] diff --git a/morley-test/Test/Michelson/Runtime.hs b/morley-test/Test/Michelson/Runtime.hs --- a/morley-test/Test/Michelson/Runtime.hs +++ b/morley-test/Test/Michelson/Runtime.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for "Morley.Michelson.Runtime". @@ -25,10 +24,9 @@ import Morley.Michelson.Runtime.GState (BigMapCounter, GState(..), initGState) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) import Morley.Tezos.Address -import Morley.Tezos.Core (toMutez) import Test.Cleveland.Instances () test_executorPure :: IO [TestTree] @@ -67,7 +65,7 @@ { tdSenderAddress = ceSender ce , tdParameter = TxTypedParam $ caParameter ca , tdEntrypoint = DefEpName - , tdAmount = toMutez 100 + , tdAmount = 100 } runExecutorM dummyNow dummyLevel dummyMaxSteps initGState $ do @@ -128,7 +126,7 @@ { tdSenderAddress = detGenKeyAddress "transferFromUnknown" , tdParameter = TxTypedParam $ caParameter ca , tdEntrypoint = DefEpName - , tdAmount = toMutez 0 + , tdAmount = 0 } ---------------------------------------------------------------------------- diff --git a/morley-test/Test/Michelson/Show.hs b/morley-test/Test/Michelson/Show.hs new file mode 100644 --- /dev/null +++ b/morley-test/Test/Michelson/Show.hs @@ -0,0 +1,102 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Tests of `Show` and `RenderDoc` instances of Michelson types. +module Test.Michelson.Show + ( unit_AnnTagsShow + , unit_AnnTagsRenderDoc + , unit_AnnotationSetShow + , unit_AnnotationSetRenderDoc + , unit_NotesShow + , unit_NotesRenderDoc + , unit_InstrAbstractShow + , unit_InstrAbstractRenderDoc + ) where + +import Debug qualified (show) + +import Test.HUnit (Assertion, assertEqual) + +import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc) +import Morley.Michelson.Typed (Notes(..), T(..)) +import Morley.Michelson.Untyped qualified as U + +render :: RenderDoc a => a -> LText +render = printDoc True . renderDoc doesntNeedParens + +-- * Annotation + +typeAnn :: U.TypeAnn +typeAnn = U.UnsafeAnnotation @U.TypeTag "type" + +fieldAnn :: U.FieldAnn +fieldAnn = U.UnsafeAnnotation @U.FieldTag "field" + +varAnn :: U.VarAnn +varAnn = U.UnsafeAnnotation @U.VarTag "var" + +unit_AnnTagsShow :: Assertion +unit_AnnTagsShow = + zipWithM_ (assertEqual @Text "Annotations' `show` produces type tags") + [Debug.show typeAnn, Debug.show fieldAnn, Debug.show varAnn] + [ "UnsafeAnnotation @TypeTag \"type\"" + , "UnsafeAnnotation @FieldTag \"field\"" + , "UnsafeAnnotation @VarTag \"var\"" + ] + +unit_AnnTagsRenderDoc :: Assertion +unit_AnnTagsRenderDoc = + zipWithM_ (assertEqual "Annotations' `renderDoc` produces Michelson annotations") + [render typeAnn, render fieldAnn, render varAnn] + [":type", "%field", "@var"] + +-- * AnnotationSet + +annSet :: U.AnnotationSet +annSet = U.AnnotationSet [typeAnn] [fieldAnn] [varAnn] + +unit_AnnotationSetShow :: Assertion +unit_AnnotationSetShow = + assertEqual @Text "AnnotationSet's `show` is stock" + (Debug.show annSet) + "AnnotationSet {asTypes = [UnsafeAnnotation @TypeTag \"type\"], asFields = [UnsafeAnnotation @FieldTag \"field\"], asVars = [UnsafeAnnotation @VarTag \"var\"]}" + +unit_AnnotationSetRenderDoc :: Assertion +unit_AnnotationSetRenderDoc = + assertEqual "AnnotationSet's `renderDoc` produces a list of annotations" + (render annSet) + ":type %field @var" + +-- * Notes + +pair :: Notes ('TPair 'TUnit 'TUnit) +pair = NTPair typeAnn fieldAnn U.noAnn varAnn U.noAnn (NTUnit U.noAnn) (NTUnit U.noAnn) + +unit_NotesShow :: Assertion +unit_NotesShow = + assertEqual @Text "Notes' `show` is stock" + (Debug.show pair) + "NTPair (UnsafeAnnotation @TypeTag \"type\") (UnsafeAnnotation @FieldTag \"field\") (UnsafeAnnotation @FieldTag \"\") (UnsafeAnnotation @VarTag \"var\") (UnsafeAnnotation @VarTag \"\") (NTUnit (UnsafeAnnotation @TypeTag \"\")) (NTUnit (UnsafeAnnotation @TypeTag \"\"))" + +unit_NotesRenderDoc :: Assertion +unit_NotesRenderDoc = + assertEqual "Notes' `renderDoc` produces a Michelson annotated type" + (render pair) + "pair :type (unit %field @var) unit" + +-- * InstrAbstract + +instr :: U.InstrAbstract U.ExpandedOp +instr = U.PAIR typeAnn varAnn fieldAnn U.noAnn + +unit_InstrAbstractShow :: Assertion +unit_InstrAbstractShow = + assertEqual @Text "InstrAbstract's `show` is stock" + (Debug.show instr) + "PAIR (UnsafeAnnotation @TypeTag \"type\") (UnsafeAnnotation @VarTag \"var\") (UnsafeAnnotation @FieldTag \"field\") (UnsafeAnnotation @FieldTag \"\")" + +unit_InstrAbstractRenderDoc :: Assertion +unit_InstrAbstractRenderDoc = + assertEqual "InstrAbstract's `renderDoc` produces an annotated Michelson instruction" + (render instr) + "PAIR :type %field @var" diff --git a/morley-test/Test/Michelson/Text.hs b/morley-test/Test/Michelson/Text.hs --- a/morley-test/Test/Michelson/Text.hs +++ b/morley-test/Test/Michelson/Text.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on 'MText'. module Test.Michelson.Text @@ -12,15 +11,15 @@ , unit_mt ) where -import Fmt (pretty) +import Fmt (Buildable, pretty) import Test.HUnit (Assertion, (@?), (@?=)) import Test.Tasty (TestTree) -import qualified Text.Megaparsec as P +import Text.Megaparsec qualified as P import Hedgehog.Gen.Michelson (genMText) import Morley.Michelson.Parser import Morley.Michelson.Text -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Util.Text (dquotes) import Test.Cleveland.Instances () @@ -30,7 +29,7 @@ parseMTextTest :: HasCallStack => Text -> Either () MText parseMTextTest t = first (const ()) $ - expectString <$> parseNoEnv (stringLiteral <* P.eof) codeSrc (dquotes t) + expectString <$> parseNoEnv @() (stringLiteral <* P.eof) codeSrc (dquotes t) where expectString = \case U.ValueString t' -> t' @@ -42,10 +41,10 @@ [ roundtripTree genMText writeMText parseMTextTest ] -- | Check value against the given predicate. -(@??) :: (Show a, HasCallStack) => a -> (a -> Bool) -> Assertion +(@??) :: (Buildable a, HasCallStack) => a -> (a -> Bool) -> Assertion (@??) val predicate = predicate val @? - ("Predicate does not hold for value " <> show val) + ("Predicate does not hold for value " <> pretty val) unit_mkMText :: Assertion unit_mkMText = do diff --git a/morley-test/Test/Michelson/Typed/AnnotatedValue.hs b/morley-test/Test/Michelson/Typed/AnnotatedValue.hs --- a/morley-test/Test/Michelson/Typed/AnnotatedValue.hs +++ b/morley-test/Test/Michelson/Typed/AnnotatedValue.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2022 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Michelson.Typed.AnnotatedValue ( unit_variant_read @@ -13,11 +12,12 @@ ) where -import Control.Lens +import Control.Lens (_Just, each, ix, (+~), (<>~), (^@..)) import Fmt (Buildable, GenericBuildable(..)) import Test.Cleveland.Instances () -import Test.Tasty.HUnit +import Test.Tasty.HUnit ((@?=)) +import Morley.Michelson.Parser (notes) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed.AnnotatedValue import Morley.Michelson.Typed.Annotation (Notes(..), starNotes) @@ -45,13 +45,18 @@ paramNotes :: Notes (ToT Param) paramNotes = - NTOr "" "" "" - (NTOr "" "p1" "p2" starNotes starNotes) - (NTOr "" "p3" "p4" starNotes nestedParamNotes) + [notes| + or + (or (int %p1) + (string %p2) + ) + (or (pair %p3 string nat) + (or %p4 (int %p1) (nat %p2)) + ) + |] nestedParamNotes :: Notes (ToT NestedParam) -nestedParamNotes = - NTOr "" "p1" "p2" starNotes starNotes +nestedParamNotes = [notes|or (int %p1) (nat %p2)|] unit_variant_read :: IO () unit_variant_read = do @@ -134,13 +139,23 @@ storageNotes :: Notes (ToT Storage) storageNotes = - NTPair "" "" "" "" "" - (NTPair "" "field1" "field2" "" "" starNotes starNotes) - (NTPair "" "field3" "field4" "" "" starNotes nestedNotes) + [notes| + pair + (pair + (int %field1) + (pair %field2 string nat) + ) + (pair + (option %field3 int) + (pair %field4 + (string %field1) + (int %field2) + ) + ) + |] nestedNotes :: Notes (ToT Nested) -nestedNotes = - NTPair "" "field1" "field2" "" "" starNotes starNotes +nestedNotes = [notes|pair (string %field1) (int %field2)|] storage :: Storage storage = Storage @@ -196,11 +211,11 @@ unit_nodes = do storageSav ^@.. nodes @?= [ ("", SomeAnnotatedValue - (NTPair "" "field1" "field2" "" "" starNotes starNotes) + [notes|pair (int %field1) (pair %field2 string nat)|] (toVal @(Integer, (MText, Natural)) $ (1, ("a", 2))) ) , ("", SomeAnnotatedValue - (NTPair "" "field3" "field4" "" "" starNotes (NTPair "" "field1" "field2" "" "" starNotes starNotes) ) + [notes|pair (option %field3 int) (pair %field4 (string %field1) (int %field2))|] (toVal @(Maybe Integer, (MText, Integer)) $ (Just 3, ("b", 4))) ) , ("field1", SomeAnnotatedValue starNotes (toVal $ sField1 storage)) @@ -233,9 +248,12 @@ collectionsNotes :: Notes (ToT Collections) collectionsNotes = - NTPair "" "listField" "" "" "" - starNotes - (NTPair "" "mapField" "bigMapField" "" "" starNotes starNotes) + [notes| + pair + (list %listField int) + (map %mapField string nat) + (big_map %bigMapField string nat) + |] collectionsSav :: SomeAnnotatedValue collectionsSav = diff --git a/morley-test/Test/Michelson/Typed/Convert.hs b/morley-test/Test/Michelson/Typed/Convert.hs --- a/morley-test/Test/Michelson/Typed/Convert.hs +++ b/morley-test/Test/Michelson/Typed/Convert.hs @@ -1,24 +1,26 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on 'Convert'. module Test.Michelson.Typed.Convert ( test_sub + , test_sub_mutez , test_sha , test_arith + , test_wrappers ) where -import Test.HUnit (assertEqual) +import Data.Vinyl.Core (Rec(..)) +import Test.HUnit (assertEqual, (@?=)) import Test.Hspec () -import Test.Tasty (TestTree) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Convert (instrToOps) import Morley.Michelson.Typed.Instr (Instr(..)) -import qualified Morley.Michelson.Typed.Instr as T (Instr(EQ, GE, GT, LE, LT, NEQ)) import Morley.Michelson.Typed.Value (Value'(..)) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Test.Cleveland.Instances () annA, annB :: U.Annotation a @@ -37,6 +39,18 @@ , U.PrimEx $ U.SUB annA ] +test_sub_mutez :: TestTree +test_sub_mutez = + testCase "SUB_MUTEZ accepts one annotation" $ + assertEqual "SUB_MUTEZ accepts one annotation" (instrToOps sub) subExpected + where + sub = PUSH (VMutez 9) `Seq` PUSH (VMutez 8) `Seq` InstrWithVarNotes (annA :| []) SUB_MUTEZ + subExpected = + [ U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TMutez U.noAnn) (U.ValueInt 9) + , U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TMutez U.noAnn) (U.ValueInt 8) + , U.PrimEx $ U.SUB_MUTEZ annA + ] + test_sha :: TestTree test_sha = testCase "SHA256 and SHA512 accept one annotation" $ do @@ -73,3 +87,15 @@ arithTOps = [T.EQ, T.NEQ, T.LT, T.GT, T.LE, T.GE] arithUOps = [U.EQ, U.NEQ, U.LT, U.GT, U.LE, U.GE] + +test_wrappers :: TestTree +test_wrappers = testGroup "instruction wrappers interact sensibly" + [ testCase "Meta under notes" do + instrToOps + (T.InstrWithNotes (Proxy @'[]) (T.NTUnit [U.annQ|meq|] :& RNil) $ + T.InstrWithVarNotes (one [U.annQ|kek|]) $ + T.Meta (T.SomeMeta ()) $ + T.UNIT + ) + @?= [U.PrimEx $ U.UNIT [U.annQ|meq|] [U.annQ|kek|]] + ] diff --git a/morley-test/Test/Michelson/Typed/Util.hs b/morley-test/Test/Michelson/Typed/Util.hs --- a/morley-test/Test/Michelson/Typed/Util.hs +++ b/morley-test/Test/Michelson/Typed/Util.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Michelson.Typed.Util'. @@ -9,8 +8,10 @@ , hprop_linearizeLeft_performance , unit_dfsInstr_counter , unit_dfsInstr_meta + , unit_dfsInstr_ctorEffectsApp ) where +import Control.Monad.Writer.Strict (Writer, runWriter, tell, writer) import Data.Default (def) import Data.Typeable (cast) @@ -46,9 +47,8 @@ dfsFoldInstr (settings False) step instr @?= Sum 2 where settings goToValues = - DfsSettings + def { dsGoToValues = goToValues - , dsCtorEffectsApp = ceaBottomToTop } step :: Instr a b -> Sum Word @@ -63,7 +63,7 @@ unit_dfsInstr_meta :: Assertion unit_dfsInstr_meta = do - let (output, prod) = dfsInstr def go input + let (output, prod) = runWriter $ dfsTraverseInstr def go input -- We don't have an untyped version of Meta, so let's pattern match instead of -- checking for equality. case output of @@ -87,7 +87,44 @@ (Meta (SomeMeta str) (Meta (SomeMeta (4 :: Word)) nilOp)) (Meta (SomeMeta (5 :: Word)) PAIR)))) - go :: Instr i o -> (Instr i o, Product Word) + go :: Instr i o -> Writer (Product Word) (Instr i o) go = \case - Meta (SomeMeta m) i | Just (v :: Word) <- cast m -> (i, Product v) - i -> (i, mempty) + Meta (SomeMeta m) i | Just (v :: Word) <- cast m -> i <$ tell (Product v) + i -> pure i + +unit_dfsInstr_ctorEffectsApp :: Assertion +unit_dfsInstr_ctorEffectsApp = do + -- simple case + dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp1 } step instr1 + @?= Product (2 * (2 + 3) * 5) + + -- ctor effects are applied to primitives + dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp2 } step instr1 + @?= Product ((2 + 1) * (2 + 1) * (1 + 2) * 5) + + -- ctor effects are applied to intermediate nodes + dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp1 } step instr2 + @?= Product (2 * (1 + 2 * (1 + 2))) + where + step :: Instr i o -> Product Int + step = \case + UNIT -> Product 2 + PUSH _ -> Product 5 + _ -> mempty + + ctorEffectsApp1 = CtorEffectsApp "custom adds for wrappers" \oldInstr -> + let addition = case oldInstr of + Nested{} -> 1 + DIP{} -> 3 + _ -> 0 + in writer . second (\(Product x) -> Product (x + addition)) . runWriter + + ctorEffectsApp2 = CtorEffectsApp "custom adds for leaves" \oldInstr -> + let addition = case oldInstr of + UNIT{} -> 1 + DROP{} -> 2 + _ -> 0 + in writer . second (\(Product x) -> Product (x + addition)) . runWriter + + instr1 = UNIT `Seq` DUP `Seq` DIP UNIT `Seq` DROP `Seq` PUSH VUnit + instr2 = UNIT `Seq` Nested (DROP `Seq` UNIT `Seq` Nested (DROP `Seq` UNIT)) diff --git a/morley-test/Test/Michelson/Typed/Value.hs b/morley-test/Test/Michelson/Typed/Value.hs --- a/morley-test/Test/Michelson/Typed/Value.hs +++ b/morley-test/Test/Michelson/Typed/Value.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on 'Value'. module Test.Michelson.Typed.Value diff --git a/morley-test/Test/Morley/Expression.hs b/morley-test/Test/Morley/Expression.hs --- a/morley-test/Test/Morley/Expression.hs +++ b/morley-test/Test/Morley/Expression.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Micheline.Expression'. @@ -13,16 +12,17 @@ , test_toExpression ) where +import Unsafe qualified (fromJust) + import Data.Aeson (FromJSON, Result(Error, Success), ToJSON(toJSON), Value(String), eitherDecode, encode, fromJSON, object, (.=)) import Data.Aeson.QQ (aesonQQ) import Data.Default (def) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import qualified Data.Set as Set +import Data.Map qualified as Map +import Data.Set qualified as Set import Data.Singletons (demote) -import qualified Data.Text as T +import Data.Text qualified as T import Hedgehog (Gen) import Test.Hspec.Expectations (shouldBe) import Test.Tasty (TestTree, testGroup) @@ -30,14 +30,15 @@ import Hedgehog.Gen.Michelson.Typed (genSimpleInstr, genValueInt, genValueMutez, genValueUnit) import Hedgehog.Gen.Michelson.Untyped (genValidType) -import qualified Hedgehog.Gen.Morley.Micheline as M -import qualified Morley.Micheline as M +import Hedgehog.Gen.Morley.Micheline qualified as M +import Morley.Micheline qualified as M +import Morley.Michelson.Parser (notes) import Morley.Michelson.Text (MText) -import qualified Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core (Mutez) import Test.Cleveland.Instances () -import Test.Cleveland.Util (unsafeFromHex) +import Test.Cleveland.Util (fromHex) import Test.Util.Hedgehog (roundtripTree) testJSON @@ -379,7 +380,7 @@ , testCase "Converting VContract to Expression" $ M.toExpression @(T.Value $ 'T.TContract 'T.TAddress) (getSampleValue @('T.TContract 'T.TAddress)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") + M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") , testCase "Converting VBigMap to Expression" $ M.toExpression @(T.Value $ 'T.TBigMap (T.ToT Integer) (T.ToT Integer)) @@ -411,7 +412,7 @@ , testCase "Converting VKey to Expression" $ M.toExpression @(T.Value 'T.TKey) (getSampleValue @('T.TKey)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082") + M.ExpressionBytes (unsafe $ fromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082") , testCase "Converting VTimestamp to Expression" $ M.toExpression @(T.Value 'T.TTimestamp) (getSampleValue @('T.TTimestamp)) `shouldBe` @@ -419,25 +420,25 @@ , testCase "Converting VAddress to Expression" $ M.toExpression @(T.Value 'T.TAddress) (getSampleValue @('T.TAddress)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") + M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") , testCase "Converting VChainId to Expression" $ M.toExpression @(T.Value 'T.TChainId) (getSampleValue @('T.TChainId)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "458aa837") + M.ExpressionBytes (unsafe $ fromHex "458aa837") , testCase "Converting VSignature to Expression" $ M.toExpression @(T.Value 'T.TSignature) (getSampleValue @('T.TSignature)) `shouldBe` - (M.ExpressionBytes $ unsafeFromHex + (M.ExpressionBytes $ unsafe $ fromHex "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd89\ \1cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201") , testCase "Converting VKeyHash to Expression" $ M.toExpression @(T.Value 'T.TKeyHash) (getSampleValue @('T.TKeyHash)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d") + M.ExpressionBytes (unsafe $ fromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d") , testCase "Converting VBls12381Fr to Expression" $ M.toExpression @(T.Value 'T.TBls12381Fr) (getSampleValue @('T.TBls12381Fr)) `shouldBe` - M.ExpressionBytes (unsafeFromHex "0100000000000000000000000000000000000000000000000000000000000000") + M.ExpressionBytes (unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000") , testCase "Converting VLam to Expression" $ M.toExpression @(T.Value $ 'T.TLambda 'T.TUnit 'T.TUnit) @@ -472,7 +473,7 @@ ] , testCase "Converting NTPair to Expression" $ - M.toExpression (T.NTPair "pair" "a" "b" U.noAnn U.noAnn (T.NTString U.noAnn) (T.NTInt "val")) `shouldBe` + M.toExpression [notes|pair :pair (string %a) (int %b :val)|] `shouldBe` M.ExpressionPrim (M.MichelinePrimAp { mpaPrim = M.MichelinePrimitive "pair" @@ -553,4 +554,4 @@ } getSampleValue :: forall t. (T.SingI t) => T.Value t - getSampleValue = fromJust $ T.sampleTypedValue $ T.sing @t + getSampleValue = Unsafe.fromJust $ T.sampleTypedValue $ T.sing @t diff --git a/morley-test/Test/OpSize.hs b/morley-test/Test/OpSize.hs --- a/morley-test/Test/OpSize.hs +++ b/morley-test/Test/OpSize.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for operation size evaluation. @@ -14,7 +13,7 @@ import Prelude hiding (EQ) -import qualified Data.Text as T +import Data.Text qualified as T import Fmt (pretty) import Hedgehog (Gen) import Test.HUnit (Assertion, (@?=)) @@ -23,12 +22,12 @@ import Hedgehog.Gen.Tezos.Address (genAddress) import Hedgehog.Gen.Tezos.Crypto (genKeyHash) -import qualified Hedgehog.Gen.Tezos.Crypto.Ed25519 as Ed25519 -import qualified Hedgehog.Gen.Tezos.Crypto.Secp256k1 as Secp256k1 +import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519 +import Hedgehog.Gen.Tezos.Crypto.Secp256k1 qualified as Secp256k1 import Morley.Michelson.Macro -import qualified Morley.Michelson.Parser as Parser +import Morley.Michelson.Parser qualified as Parser import Morley.Michelson.Typed -import Morley.Michelson.Untyped (unsafeBuildEpName) +import Morley.Michelson.Untyped (buildEpName) import Morley.Michelson.Untyped.OpSize import Morley.Tezos.Core import Morley.Tezos.Crypto @@ -107,9 +106,9 @@ , valueTestCaseExt "plain KT address" "address" (dquotes $ pretty (gen genAddress)) 47 , let addr = gen genAddress in valueTestCaseExt "empty entrypoint" "address" (dquotes $ pretty addr <> "%") 48 - , let epAddr = EpAddress(gen genAddress) (unsafeBuildEpName "a") + , let epAddr = EpAddress (gen genAddress) . unsafe $ buildEpName "a" in valueTestCaseExt "short entrypoint" "address" (dquotes $ pretty epAddr) 49 - , let epAddr = EpAddress (gen genAddress) (unsafeBuildEpName . mconcat $ replicate 8 "a") + , let epAddr = EpAddress (gen genAddress) . unsafe . buildEpName . mconcat $ replicate 8 "a" in valueTestCaseExt "long entrypoint" "address" (dquotes $ pretty epAddr) 56 ] -- ed25519 and secp256k1 keys have different size @@ -201,7 +200,7 @@ ] where typeTestCase t gas = - testCase (show t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas + testCase (toString t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas test_Instructions :: [TestTree] test_Instructions = @@ -272,7 +271,7 @@ namedInstrTestCase testName (instr <> "; FAILWITH") gas instrTestCase instr gas = - namedInstrTestCase (show instr) instr gas + namedInstrTestCase (toString instr) instr gas instrTestCaseFailWith instr gas = instrTestCase (instr <> "; FAILWITH") gas diff --git a/morley-test/Test/Optimizer.hs b/morley-test/Test/Optimizer.hs --- a/morley-test/Test/Optimizer.hs +++ b/morley-test/Test/Optimizer.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Tests for optimizer. module Test.Optimizer @@ -30,21 +32,21 @@ import Prelude hiding (EQ) import Data.Default (def) -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) +import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Data.Text.Lazy (strip) import Test.HUnit (Assertion, (@?=)) import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Optimizer import Morley.Michelson.Printer (printSomeContract) +import Morley.Michelson.Runtime.Import (importUsing, readSomeContractExt) import Morley.Michelson.Text import Morley.Michelson.TypeCheck (mapSomeContract) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Michelson.Untyped.Annotation (noAnn) import Morley.Util.PeanoNatural (PeanoNatural(..)) import Test.Cleveland.Instances () -import Test.Cleveland.Michelson (importSomeContract) import Test.Util.Contracts import Test.Util.HUnit @@ -263,7 +265,7 @@ where optimizerTest :: (FilePath, FilePath) -> Assertion optimizerTest (srcPath, optPath) = do - someContract <- importSomeContract srcPath + someContract <- importUsing readSomeContractExt srcPath let optimized :: T.SomeContract optimized = mapSomeContract (optimize . dropWithLoc) someContract diff --git a/morley-test/Test/Parser.hs b/morley-test/Test/Parser.hs --- a/morley-test/Test/Parser.hs +++ b/morley-test/Test/Parser.hs @@ -1,37 +1,38 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- 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 - ( unit_Parse_contracts - , unit_Parse_bad_contracts - , unit_Value - , unit_string_literal - , unit_annotation - , unit_IF - , unit_MAP - , unit_PAIR - , unit_UNPAIR - , unit_pair_type - , unit_Right_combed_pair_type - , unit_Right_combed_pair_type_with_annotations - , unit_tuple_type - , unit_or_type - , unit_lambda_type - , unit_list_type - , unit_set_type - , unit_Pair_constructor - , unit_Right_combed_Pair_constructor - , unit_PrintComment - , unit_ParserException - , unit_letType - , unit_block_comment - , unit_UNPAPAIR + ( 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 qualified Data.List.NonEmpty as NE -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) -import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy) +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) @@ -41,191 +42,241 @@ 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) -unit_Parse_contracts :: Expectation -unit_Parse_contracts = do - files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts - mapM_ (checkFile True) files +---------------------------------------------------------------------------- +-- Contracts +---------------------------------------------------------------------------- -unit_Parse_bad_contracts :: Expectation -unit_Parse_bad_contracts = do - files <- getUnparsableContracts - mapM_ (checkFile False) files +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 + ] -checkFile :: Bool -> FilePath -> Expectation -checkFile shouldParse file = do - code <- Utf8.readFile file - case parse P.program file code of - Left err - | shouldParse -> expectationFailure $ errorBundlePretty err - Right _ - | not shouldParse -> expectationFailure $ "Managed to parse " <> file - _ -> pass +---------------------------------------------------------------------------- +-- Values +---------------------------------------------------------------------------- -unit_Value :: Expectation -unit_Value = do - P.parseNoEnv P.value codeSrc "{}" `shouldBe` - Right Mo.ValueNil - P.parseNoEnv P.value codeSrc "{PUSH int 5;}" `shouldBe` - (Right . ValueLambda $ NE.fromList - [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)] +test_value :: [TestTree] +test_value = testSatisfyingCases P.value + [ ( "{}" + , Right Mo.ValueNil ) - P.parseNoEnv P.value codeSrc "{1; 2}" `shouldBe` - (Right . Mo.ValueSeq $ NE.fromList - [Mo.ValueInt 1, Mo.ValueInt 2] + , ( "{PUSH int 5;}" + , Right . ValueLambda $ NE.fromList + [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)] ) - P.parseNoEnv P.value codeSrc "{Elt 1 2; Elt 3 4}" `shouldBe` - (Right . Mo.ValueMap $ NE.fromList - [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)] + , ( "{1; 2}" + , Right . Mo.ValueSeq $ NE.fromList + [Mo.ValueInt 1, Mo.ValueInt 2] ) - P.parseNoEnv P.value codeSrc "{DIP DROP;}" `shouldBe` - Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| [])) - P.parseNoEnv P.value codeSrc "{DIP DROP;somecontent}" `shouldSatisfy` isLeft - P.parseNoEnv P.value codeSrc "{{ }; {}; {PUSH int 5; DROP}}" `shouldBe` - 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) - ] - )) - P.parseNoEnv P.value codeSrc "{{}; {}; {5}}" `shouldBe` - Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])])) - P.parseNoEnv P.value codeSrc "{{}; {5}; {Push int 5}}" `shouldSatisfy` isLeft - -unit_string_literal :: Expectation -unit_string_literal = do - P.parseNoEnv P.stringLiteral codeSrc "\"\"" `shouldSatisfy` isRight - P.parseNoEnv P.stringLiteral codeSrc "\" \\n \"" `shouldSatisfy` isRight - P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft - P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft - -unit_annotation :: Expectation -unit_annotation = do - P.parseNoEnv PA.noteV codeSrc "@" `shouldSatisfy` isRight - P.parseNoEnv PA.noteV codeSrc "@_" `shouldSatisfy` isRight - P.parseNoEnv PA.noteV codeSrc "@a." `shouldSatisfy` isRight - P.parseNoEnv PA.noteV codeSrc "@7a" `shouldSatisfy` isRight - P.parseNoEnv PA.noteV codeSrc "@.a" `shouldSatisfy` isLeft - P.parseNoEnv PA.noteV codeSrc "@@@" `shouldSatisfy` isLeft - P.parseNoEnv PA.noteV codeSrc "@a b" `shouldSatisfy` isLeft - P.parseNoEnv PA.noteV codeSrc "@a\\" `shouldSatisfy` isLeft - -- TODO [#48] these are special annotations and should not always be accepted - P.parseNoEnv PA.noteV codeSrc "@%" `shouldSatisfy` isRight - P.parseNoEnv PA.noteV codeSrc "@%%" `shouldSatisfy` isRight - -unit_IF :: Expectation -unit_IF = do - P.parseNoEnv P.codeEntry codeSrc "{IF {} {};}" `shouldBe` - Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)] - P.parseNoEnv P.codeEntry codeSrc "{IFEQ {} {};}" `shouldBe` - Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)] - P.parseNoEnv P.codeEntry codeSrc "{IFCMPEQ {} {};}" `shouldBe` - Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)] - -unit_MAP :: Expectation -unit_MAP = do - parseNoEnv P.codeEntry codeSrc "{MAP {};}" `shouldBe` - Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)] - parseNoEnv P.codeEntry codeSrc "{MAP_CAR {};}" `shouldBe` - Prelude.Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)] - -unit_PAIR :: Expectation -unit_PAIR = do - P.parseNoEnv P.codeEntry codeSrc "{PAIR;}" `shouldBe` - Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)] - P.parseNoEnv P.codeEntry codeSrc "{PAIR %a;}" `shouldBe` - Prelude.Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)] - P.parseNoEnv P.codeEntry codeSrc "{PAIR %0;}" `shouldBe` - Prelude.Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)] - P.parseNoEnv P.codeEntry codeSrc "{PAPAIR;}" `shouldBe` - Prelude.Right - [flip Mac (srcPos 0 1) $ - PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn))) - noAnn noAnn - ] - -unit_UNPAPAIR :: Expectation -unit_UNPAPAIR = do - let unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1) - - P.parseNoEnv P.codeEntry "" "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}" `shouldBe` - Prelude.Right [unpapair] - - P.parseNoEnv P.codeEntry "" "{UNPAPAIR @a %b @c %d %e @f;}" `shouldBe` - Prelude.Right [unpapair] - - P.parseNoEnv P.codeEntry "" "{UNPAPAIR;}" `shouldBe` - Prelude.Right [unpapair] - -unit_UNPAIR :: Expectation -unit_UNPAIR = do - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)] + , ( "{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 :| [])])) + ) + ] ++ - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %a;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)] + testSatisfyingCasesPredicate P.value + [ ("{DIP DROP;somecontent}", isLeft) + , ("{{}; {5}; {Push int 5}}", isLeft) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)] +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) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a %b;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)] +---------------------------------------------------------------------------- +-- Annotations +---------------------------------------------------------------------------- - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %b @a;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)] +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) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)] +---------------------------------------------------------------------------- +-- Instructions +---------------------------------------------------------------------------- - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)] +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)] + ) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "") (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)] + ) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c %d;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (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 + ] + ) + ] - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)] +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) - P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a @b;}" `shouldBe` - Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (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 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 ('@' :| "")) + ] - -- should fail because the two var anns are not "grouped" together. - handleTrivialError - "{UNPAIR @a %c %d @b;}" - (P.codeEntry) - (Tokens ('@' :| "")) +---------------------------------------------------------------------------- +-- Types +---------------------------------------------------------------------------- -unit_pair_type :: Expectation -unit_pair_type = do - P.parseNoEnv P.type_ codeSrc "pair unit unit" `shouldBe` Right unitPair - P.parseNoEnv P.type_ codeSrc "(unit, unit)" `shouldBe` Right unitPair - P.parseNoEnv P.type_ codeSrc "(key, (int, (string, bool)))" - `shouldSatisfy` isRight - P.parseNoEnv P.type_ codeSrc "(signature, chain_id, string, bool)" - `shouldSatisfy` isRight +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 -unit_Right_combed_pair_type :: Expectation -unit_Right_combed_pair_type = do - P.parseNoEnv P.type_ codeSrc "pair unit int string" `shouldBe` Right rightCombPair - P.parseNoEnv P.type_ codeSrc "(unit, int, string)" `shouldBe` Right rightCombPair - where rightCombPair :: Mo.Ty rightCombPair = Mo.Ty @@ -241,11 +292,6 @@ ) noAnn -unit_Right_combed_pair_type_with_annotations :: Expectation -unit_Right_combed_pair_type_with_annotations = do - P.parseNoEnv P.type_ codeSrc "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)" `shouldBe` Right rightCombPairWithAnns - P.parseNoEnv P.type_ codeSrc "(unit :t1 %x, int :t2 %y, string %z :t3) :t" `shouldBe` Right rightCombPairWithAnns - where rightCombPairWithAnns :: Mo.Ty rightCombPairWithAnns = Mo.Ty @@ -261,57 +307,66 @@ ) "t" -unit_tuple_type :: Expectation -unit_tuple_type = do - P.parseNoEnv P.type_ codeSrc "(int, int, bool, unit, nat)" - `shouldBe` Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat))) - P.parseNoEnv P.type_ codeSrc - "(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))))))))))))))))" - `shouldBe` Right (bigPair 16) +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)) -unit_or_type :: Expectation -unit_or_type = do - P.parseNoEnv P.type_ codeSrc "or unit unit" `shouldBe` Right unitOr - P.parseNoEnv P.type_ codeSrc "(unit | unit)" `shouldBe` Right unitOr - P.parseNoEnv P.type_ codeSrc "(chain_id | (int | (string | bool)))" - `shouldSatisfy` isRight - P.parseNoEnv P.type_ codeSrc "or unit unit kek" - `shouldSatisfy` isLeft +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 -unit_lambda_type :: Expectation -unit_lambda_type = do - P.parseNoEnv P.type_ codeSrc "lambda unit unit" `shouldBe` Right lambdaUnitUnit - P.parseNoEnv P.type_ codeSrc "\\unit -> unit" `shouldBe` Right lambdaUnitUnit - P.parseNoEnv P.type_ codeSrc "lambda int (signature, int)" `shouldSatisfy` isRight +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 -unit_list_type :: Expectation -unit_list_type = do - P.parseNoEnv P.type_ codeSrc "list unit" `shouldBe` Right unitList - P.parseNoEnv P.type_ codeSrc "[unit]" `shouldBe` Right unitList - P.parseNoEnv P.type_ codeSrc "[(key, key)]" `shouldSatisfy` isRight +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 -unit_set_type :: Expectation -unit_set_type = do - P.parseNoEnv P.type_ codeSrc "set int" `shouldBe` Right intSet - P.parseNoEnv P.type_ codeSrc "set (pair int int)" `shouldBe` Right intPairSet - P.parseNoEnv P.type_ codeSrc "{int}" `shouldBe` Right intSet - P.parseNoEnv P.type_ codeSrc "{(pair int int)}" `shouldBe` Right intPairSet +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 = @@ -320,104 +375,227 @@ 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 -unit_Pair_constructor :: Expectation -unit_Pair_constructor = do - P.parseNoEnv P.value codeSrc "Pair Unit Unit" `shouldBe` Right unitPair - P.parseNoEnv P.value codeSrc "(Unit, Unit)" `shouldBe` Right unitPair +---------------------------------------------------------------------------- +-- 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 -unit_Right_combed_Pair_constructor :: Expectation -unit_Right_combed_Pair_constructor = do - P.parseNoEnv P.value codeSrc "Pair Unit 3 \"Hi\"" `shouldBe` Right unitPair - P.parseNoEnv P.value codeSrc "(Unit, 3, \"Hi\")" `shouldBe` Right unitPair - where - unitPair :: Mo.Value' Mo.ParsedOp - unitPair = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi")) + unitPairRightCombed :: Mo.Value' Mo.ParsedOp + unitPairRightCombed = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi")) -unit_PrintComment :: Expectation -unit_PrintComment = do - P.parseNoEnv P.printComment codeSrc "\"Sides are %[0] x %[1]\"" `shouldBe` - Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)]) - P.parseNoEnv P.printComment codeSrc "\"%[0] x\"" `shouldBe` - Right (PrintComment [Right (StackRef 0), Left " x"]) - P.parseNoEnv P.printComment codeSrc "\"%[0]x%[1]\"" `shouldBe` - Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)]) - P.parseNoEnv P.printComment codeSrc "\"%[0]%[1]\"" `shouldBe` - Right (PrintComment [Right (StackRef 0), Right (StackRef 1)]) - P.parseNoEnv P.printComment codeSrc "\"xxx\"" `shouldBe` - Right (PrintComment [Left "xxx"]) - P.parseNoEnv P.printComment codeSrc "\"\"" `shouldBe` - Right (PrintComment []) +---------------------------------------------------------------------------- +-- Comments +---------------------------------------------------------------------------- -unit_ParserException :: Expectation -unit_ParserException = do - 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_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 a -> CustomParserException -> Expectation -handleCustomError text parser customException = + :: HasCallStack => Text -> Parser' LetEnv a -> CustomParserException -> TestTree +handleCustomError text parser customException = testCase (toString text) $ case P.parseNoEnv parser codeSrc text of - Right _ -> expectationFailure "expecting parser to fail" + Right _ -> assertFailure "expecting parser to fail" Left bundle -> case toList $ bundleErrors bundle of [FancyError _ (toList -> [ErrorCustom e])] -> e `shouldBe` customException _ -> - expectationFailure $ + assertFailure $ "expecting single ErrorCustom, but got " <> errorBundlePretty bundle handleTrivialError - :: HasCallStack => Text -> Parser a -> ErrorItem Char -> Expectation -handleTrivialError text parser errorItem = + :: HasCallStack => Text -> Parser' LetEnv a -> ErrorItem Char -> TestTree +handleTrivialError text parser errorItem = testCase (toString text) $ case P.parseNoEnv parser codeSrc text of - Right _ -> expectationFailure "expecting parser to fail" + Right _ -> assertFailure "expecting parser to fail" Left bundle -> case toList $ bundleErrors bundle of [TrivialError _ e _] -> e `shouldBe` (Just errorItem) _ -> - expectationFailure $ + assertFailure $ "expecting single TrivialError, but got " <> errorBundlePretty bundle -unit_letType :: Expectation -unit_letType = do - P.parseNoEnv P.letType codeSrc "type kek = int" `shouldSatisfy` isRight - -- They used to be prohibited, but now we permit them. - P.parseNoEnv P.letType codeSrc "type Parameter = int" `shouldSatisfy` isRight - P.parseNoEnv P.letType codeSrc "type Storage = int" `shouldSatisfy` isRight +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 -unit_block_comment :: Expectation -unit_block_comment = - forM_ validBlockComments $ \blockComment -> - P.parseNoEnv PL.mSpace codeSrc blockComment `shouldBe` Right () - where - validBlockComments = - [ "/* */" - , " /* */" - , "/* */ " - , "/* */;" - , "/* */ ;" - , "/* */\n;" - ] +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) diff --git a/morley-test/Test/Preprocess.hs b/morley-test/Test/Preprocess.hs --- a/morley-test/Test/Preprocess.hs +++ b/morley-test/Test/Preprocess.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for preprocessing. @@ -14,13 +13,14 @@ import Morley.Michelson.Preprocess (transformBytes, transformStrings) import Morley.Michelson.Text -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Michelson.Untyped.Annotation (noAnn) unit_Sample_preprocess :: Assertion unit_Sample_preprocess = do - transformStrings False (f (unsafeMkMText . toText)) (sample (T.VString . unsafeMkMText)) @?= (expected (T.VString . unsafeMkMText)) + transformStrings False (f (unsafe . mkMText . toText)) (sample (T.VString . unsafe . mkMText)) + @?= (expected (T.VString . unsafe . mkMText)) transformBytes False (f fromString) (sample T.VBytes) @?= (expected T.VBytes) where f :: (Eq a) => (String -> a) -> a -> a diff --git a/morley-test/Test/Printer/Michelson.hs b/morley-test/Test/Printer/Michelson.hs --- a/morley-test/Test/Printer/Michelson.hs +++ b/morley-test/Test/Printer/Michelson.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + module Test.Printer.Michelson ( unit_Roundtrip , unit_let_macro @@ -12,7 +14,7 @@ , unit_Views ) where -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) +import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Data.Text.Lazy (strip) import Fmt (pretty) import Generics.SYB (everywhere, mkT) @@ -20,8 +22,9 @@ import Morley.Michelson.Parser (MichelsonSource(..)) import Morley.Michelson.Printer (printSomeContract, printUntypedContract) -import Morley.Michelson.Runtime (parseExpandContract) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Runtime (parseExpandContractExt) +import Morley.Michelson.Runtime.Import (importUsing, readUntypedContractExt) +import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Instr (ExpandedOp(..)) import Test.Cleveland.Michelson (importSomeContract, importUntypedContract) @@ -86,7 +89,7 @@ where morleyRoundtripPrintTest :: FilePath -> Assertion morleyRoundtripPrintTest filePath = do - contract1 <- importUntypedContract filePath + contract1 <- importUsing readUntypedContractExt filePath contract2 <- printAndParse filePath contract1 -- We don't expect that `contract1` equals `contract2`, -- because during printing we lose extra instructions. @@ -106,13 +109,13 @@ unit_let_macro :: Assertion unit_let_macro = do let filePath = inContractsDir "ill-typed/letblock_trivial.mtz" - contract <- printAndParse filePath =<< importUntypedContract filePath + contract <- printAndParse filePath =<< importUsing readUntypedContractExt filePath let ops = concatMap U.flattenExpandedOp (U.contractCode contract) ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP] printAndParse :: FilePath -> U.Contract -> IO U.Contract printAndParse fp contract1 = - case parseExpandContract (MSFile fp) (toText $ printUntypedContract True contract1) of + case parseExpandContractExt (MSFile fp) (toText $ printUntypedContract True contract1) of Left err -> assertFailure ("Failed to parse printed " <> fp <> ": " <> pretty err) Right contract2 -> pure contract2 diff --git a/morley-test/Test/Serialization/Aeson.hs b/morley-test/Test/Serialization/Aeson.hs --- a/morley-test/Test/Serialization/Aeson.hs +++ b/morley-test/Test/Serialization/Aeson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Serialization.Aeson ( test_Roundtrip diff --git a/morley-test/Test/Serialization/Typed/Michelson.hs b/morley-test/Test/Serialization/Typed/Michelson.hs --- a/morley-test/Test/Serialization/Typed/Michelson.hs +++ b/morley-test/Test/Serialization/Typed/Michelson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE OverloadedLists #-} @@ -8,7 +7,7 @@ ( spec_Serialization ) where -import qualified Data.Aeson as J +import Data.Aeson qualified as J import Data.Aeson.QQ (aesonQQ) import Data.Typeable (typeRep) import Test.Hspec (Spec, describe, it) @@ -17,13 +16,12 @@ import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Text import Morley.Michelson.Typed -import Morley.Tezos.Address (Address(..), unsafeParseAddress) -import Morley.Tezos.Core (Mutez, Timestamp, parseChainId, timestampFromSeconds, toMutez) +import Morley.Tezos.Address (Address(..), parseAddress) +import Morley.Tezos.Core (Mutez, Timestamp, parseChainId, timestampFromSeconds) import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash(..), parseKeyHash, parsePublicKey, parseSignature) -import qualified Morley.Tezos.Crypto.BLS12381 as BLS +import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Test.Cleveland.Instances () -import Test.Cleveland.Util import Test.Serialization.Util spec_Serialization :: Spec @@ -180,17 +178,17 @@ mutezTest = serializeSpec @Mutez - [ Example "0" $ toMutez 0 ~: "050000" ~: [aesonQQ| { "int": "0" } |] - , Example "1" $ toMutez 1 ~: "050001" ~: [aesonQQ| { "int": "1" } |] - , Example "63" $ toMutez 63 ~: "05003f" ~: [aesonQQ| { "int": "63" } |] - , Example "64" $ toMutez 64 ~: "05008001" ~: [aesonQQ| { "int": "64" } |] - , Example "65" $ toMutez 65 ~: "05008101" ~: [aesonQQ| { "int": "65" } |] - , Example "127" $ toMutez 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127" } |] - , Example "128" $ toMutez 128 ~: "05008002" ~: [aesonQQ| { "int": "128" } |] - , Example "129" $ toMutez 129 ~: "05008102" ~: [aesonQQ| { "int": "129" } |] - , Example "191" $ toMutez 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191" } |] - , Example "192" $ toMutez 192 ~: "05008003" ~: [aesonQQ| { "int": "192" } |] - , Example "193" $ toMutez 193 ~: "05008103" ~: [aesonQQ| { "int": "193" } |] + [ Example "0" $ 0 ~: "050000" ~: [aesonQQ| { "int": "0" } |] + , Example "1" $ 1 ~: "050001" ~: [aesonQQ| { "int": "1" } |] + , Example "63" $ 63 ~: "05003f" ~: [aesonQQ| { "int": "63" } |] + , Example "64" $ 64 ~: "05008001" ~: [aesonQQ| { "int": "64" } |] + , Example "65" $ 65 ~: "05008101" ~: [aesonQQ| { "int": "65" } |] + , Example "127" $ 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127" } |] + , Example "128" $ 128 ~: "05008002" ~: [aesonQQ| { "int": "128" } |] + , Example "129" $ 129 ~: "05008102" ~: [aesonQQ| { "int": "129" } |] + , Example "191" $ 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191" } |] + , Example "192" $ 192 ~: "05008003" ~: [aesonQQ| { "int": "192" } |] + , Example "193" $ 193 ~: "05008103" ~: [aesonQQ| { "int": "193" } |] ] natTest :: Spec @@ -236,7 +234,7 @@ serializeSpec @KeyHash [ Example "KeyHash" $ - leftToShowPanic (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") + unsafe (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ~: "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78" ~: [aesonQQ| { "bytes": "0002298c03ed7d454a101eb7022bc95f7e5f41ac78" } |] ] @@ -273,7 +271,7 @@ ~: [aesonQQ| { "bytes": "019812c669d9e8ff1a61bf8c57e33b955f074d832600" } |] ] where - parseAddrs = map $ first unsafeParseAddress + parseAddrs = map $ first (unsafe . parseAddress) keyTest :: Spec keyTest = @@ -298,12 +296,12 @@ [aesonQQ| { "bytes": "0203dcb1916c475902f2b1083212e1b4e6f8ce1531710218c7d34340439f47040e7c" } |] ] where - item keyStr keyBytes json = ( leftToShowPanic $ parsePublicKey keyStr, (keyBytes, json) ) + item keyStr keyBytes json = ( unsafe $ parsePublicKey keyStr, (keyBytes, json) ) chainIdTest :: Spec chainIdTest = serializeSpecManual VChainId "chain_id" allTestMethods $ examples - [ leftToShowPanic + [ unsafe (parseChainId "NetXUdfLh6Gm88t") ~: "0x050a00000004458aa837" ~: [aesonQQ| { "bytes": "458aa837" } |] @@ -334,7 +332,7 @@ [aesonQQ| { "bytes": "da632d7f267673fab5a40562778a6890b6ada9665d53d7ff318e3399e032b3986588dadcf3bf3b549592f7b8ea1365273fbef5f4883c3430ed32e8ae24017be1" } |] ] where - item sigStr sigBytes json = (leftToShowPanic $ parseSignature sigStr, (sigBytes, json)) + item sigStr sigBytes json = (unsafe $ parseSignature sigStr, (sigBytes, json)) contractTest :: Spec contractTest = do @@ -369,8 +367,8 @@ ~: [aesonQQ| { "bytes": "000092b72c0fa1064331a641131f572e7f2abb9a890b61" } |] ] where - parseAddrs = map $ first unsafeParseAddress - parseEpAddrs = map $ first unsafeParseEpAddress + parseAddrs = map $ first (unsafe . parseAddress) + parseEpAddrs = map $ first (unsafe . parseEpAddress) mkEpVContract :: forall p. ParameterScope p => EpAddress -> Value ('TContract p) mkEpVContract EpAddress{..} = @@ -381,7 +379,7 @@ serializeSpecManual toVal "simple ticket" toJsonTestMethod $ examples $ [ Ticket - { tTicketer = unsafeParseAddress "tz1Zk7f1Ywii8QS11L63YqqtcneB64QWBas9" + { tTicketer = unsafe $ parseAddress "tz1Zk7f1Ywii8QS11L63YqqtcneB64QWBas9" , tData = [mt|a|] , tAmount = 10 } diff --git a/morley-test/Test/Serialization/Untyped/Michelson.hs b/morley-test/Test/Serialization/Untyped/Michelson.hs --- a/morley-test/Test/Serialization/Untyped/Michelson.hs +++ b/morley-test/Test/Serialization/Untyped/Michelson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE OverloadedLists #-} @@ -10,7 +9,7 @@ import Prelude hiding (Ordering(..)) -import qualified Data.Aeson as J +import Data.Aeson qualified as J import Data.Aeson.QQ (aesonQQ) import Fmt (pretty) import Test.Hspec (Spec, describe, it, shouldSatisfy) @@ -21,9 +20,9 @@ import Morley.Michelson.Interpret.Pack (packValue', packValuePrefix, toBinary') import Morley.Michelson.Interpret.Unpack (unpackUValue', unpackValue') import Morley.Michelson.Macro (expandList) -import qualified Morley.Michelson.Parser as Parser +import Morley.Michelson.Parser qualified as Parser import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core (ChainId(..)) import Test.Cleveland.Instances (HasInstrCallStack(..)) import Test.Cleveland.Util @@ -132,7 +131,7 @@ unpackNegSpec :: String -> Text -> Spec unpackNegSpec name encodedHex = it name $ - let encoded = unsafeFromHex (stripOptional0x encodedHex) + let encoded = unsafe . fromHex $ stripOptional0x encodedHex in unpackUValue' encoded `shouldSatisfy` isLeft deserializeNegSpec :: String -> Text -> J.Value -> Spec @@ -1223,6 +1222,13 @@ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, { "prim": "SUB", "annots": [ "@s" ] }, { "prim": "DROP" } ] |] + , "PUSH mutez 1; PUSH mutez 2; SUB_MUTEZ @sm; DROP" + ~: "0x0502000000170743036a00010743036a000204930000000340736d0320" + ~: [aesonQQ| + [ { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "1" } ] }, + { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "2" } ] }, + { "prim": "SUB_MUTEZ", "annots": [ "@sm" ] }, { "prim": "DROP" } ] + |] , "PUSH int 1; PUSH int 2; MUL @m; DROP" ~: "0x0502000000160743035b00010743035b0002043a00000002406d0320" ~: [aesonQQ| @@ -1489,6 +1495,13 @@ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, { "prim": "SUB" }, { "prim": "DROP" } ] |] + , "PUSH mutez 1; PUSH mutez 2; SUB_MUTEZ; DROP" + ~: "0x0502000000100743036a00010743036a000203930320" + ~: [aesonQQ| + [ { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "1" } ] }, + { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "2" } ] }, + { "prim": "SUB_MUTEZ" }, { "prim": "DROP" } ] + |] , "PUSH int 1; PUSH int 2; MUL; DROP" ~: "0x0502000000100743035b00010743035b0002033a0320" ~: [aesonQQ| @@ -2658,7 +2671,7 @@ deserializeReadableSpec name encodedHex json = describe name $ do it "From binary" $ - let encoded = unsafeFromHex (stripOptional0x encodedHex) + let encoded = unsafe . fromHex $ stripOptional0x encodedHex in runUnpack @t encoded `shouldSatisfy` isRight it "From json" $ case J.eitherDecode' @Expression (J.encode json) of @@ -2670,9 +2683,9 @@ lengthsAreNotIgnoredTest = describe "Lengths are not ignored in ChainId" $ do let chainId = UnsafeChainId "\0\0\0\0" - properEncoded = unsafeFromHex "050a0000000400000000" - badEncodedGt = unsafeFromHex "050a0000000500000000" - badEncodedLt = unsafeFromHex "050a0000000300000000" + properEncoded = unsafe $ fromHex "050a0000000400000000" + badEncodedGt = unsafe $ fromHex "050a0000000500000000" + badEncodedLt = unsafe $ fromHex "050a0000000300000000" it "Can be properly encoded" $ unpackValue' @'TChainId properEncoded == Right (VChainId chainId) diff --git a/morley-test/Test/Serialization/Util.hs b/morley-test/Test/Serialization/Util.hs --- a/morley-test/Test/Serialization/Util.hs +++ b/morley-test/Test/Serialization/Util.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE OverloadedLists #-} @@ -18,7 +17,7 @@ , (~:) ) where -import qualified Data.Aeson as J +import Data.Aeson qualified as J import Data.Aeson.Encode.Pretty (Indent(Spaces), confCompare, confIndent, defConfig, encodePretty') import Fmt (pretty) import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy) @@ -64,7 +63,7 @@ fromBinaryTestMethodImpl doUnpack = one $ TestMethod "From binary" $ \val encodedHex _ -> - doUnpack (unsafeFromHex encodedHex) `shouldBe` Right val + doUnpack (unsafe . fromHex $ encodedHex) `shouldBe` Right val toJsonTestMethodImpl :: (ToExpression t) => HasCallStack => [TestMethod t] toJsonTestMethodImpl = one $ @@ -110,7 +109,7 @@ deserializeNegSpecImpl doUnpack name encodedHex json = describe name $ do it "From binary" $ - let encoded = unsafeFromHex (stripOptional0x encodedHex) + let encoded = unsafe . fromHex $ stripOptional0x encodedHex in doUnpack encoded `shouldSatisfy` isLeft it "From json" $ case J.eitherDecode' @Expression (J.encode json) of diff --git a/morley-test/Test/Tezos/Address.hs b/morley-test/Test/Tezos/Address.hs --- a/morley-test/Test/Tezos/Address.hs +++ b/morley-test/Test/Tezos/Address.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Tezos.Address'. @@ -17,10 +16,8 @@ import Test.Tasty.HUnit (testCase) import Hedgehog.Gen.Tezos.Address (genAddress) -import Morley.Tezos.Address - (Address, formatAddress, parseAddress, parseAddressRaw, ta, unsafeParseAddress, - unsafeParseAddressRaw) -import Test.Cleveland.Util (fromHex, unsafeFromHex) +import Morley.Tezos.Address (formatAddress, parseAddress, ta) +import Test.Cleveland.Util (parseAddressFromHex) import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) @@ -37,9 +34,9 @@ [ testCase "Successfully parses valid sample data in canonical form" $ forM_ sampleAddresses (\(a, _) -> bimap STB STB (parseAddress a) `shouldSatisfy` isRight) , testCase "Successfully parses valid sample data in raw byte form" $ - forM_ sampleAddresses (\(_, b) -> bimap STB STB (parseAddressRaw . unsafeFromHex $ b) `shouldSatisfy` isRight) + forM_ sampleAddresses (\(_, b) -> bimap STB STB (parseAddressFromHex b) `shouldSatisfy` isRight) , testCase "Parsed addresses are equivalent in canonical and raw byte form" $ - forM_ sampleAddresses (\(a, b) -> (STB . unsafeParseAddressRaw . unsafeFromHex $ b) @?= (STB . unsafeParseAddress $ a)) + forM_ sampleAddresses (\(a, b) -> (STB . unsafe $ parseAddressFromHex b) @?= (STB . unsafe $ parseAddress a)) , testCase "Fails to parse invalid data" $ do forM_ invalidAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isLeft) ] @@ -47,26 +44,21 @@ test_decodeAddress :: [TestTree] test_decodeAddress = mconcat [ [ testCase ("Successfully encodes " <> toString b) - (formatAddress (unsafeParseAddressRaw (unsafeFromHex b)) @?= a) | (a, b) <- sampleAddresses ] + (formatAddress (unsafe $ parseAddressFromHex b) @?= a) | (a, b) <- sampleAddresses ] , [ testCase ("Fails to parse invalid address " <> toString a) - (parseInvalidAddresses a `shouldSatisfy` isNothing) | a <- invalidRawAddresses ] + (parseAddressFromHex a `shouldSatisfy` isLeft) | a <- invalidRawAddresses ] ] - where - parseInvalidAddresses :: Text -> Maybe Address - parseInvalidAddresses a = do - bs <- fromHex a - rightToMaybe (parseAddressRaw bs) unit_ta :: Assertion unit_ta = do [ta|tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU|] - @?= unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU" + @?= unsafe (parseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU") [ta|tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd|] - @?= unsafeParseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd" + @?= unsafe (parseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd") [ta|KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45|] - @?= unsafeParseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45" + @?= unsafe (parseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45") [ta|KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh|] - @?= unsafeParseAddress "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh" + @?= unsafe (parseAddress "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh") sampleAddresses :: [(Text, Text)] sampleAddresses = diff --git a/morley-test/Test/Tezos/Core.hs b/morley-test/Test/Tezos/Core.hs --- a/morley-test/Test/Tezos/Core.hs +++ b/morley-test/Test/Tezos/Core.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Tezos.Core ( test_ParseTimestamp diff --git a/morley-test/Test/Tezos/Crypto.hs b/morley-test/Test/Tezos/Crypto.hs --- a/morley-test/Test/Tezos/Crypto.hs +++ b/morley-test/Test/Tezos/Crypto.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Tezos.Crypto'. @@ -14,6 +13,7 @@ , unit_Failing_Key_Hashing ) where +import Fmt (pretty) import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Hspec (Expectation, shouldSatisfy) import Test.Tasty (TestTree, testGroup) @@ -21,7 +21,7 @@ import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSecretKey, genSignature) import Morley.Tezos.Crypto -import Test.Cleveland.Util (fromHex, partialParse, unsafeFromHex) +import Test.Cleveland.Util (fromHex) import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) test_Roundtrip :: [TestTree] @@ -220,15 +220,15 @@ checkSignatureSample sd = checkSignature publicKey signature (sdBytes sd) @?= sdValid sd where - publicKey = partialParse parsePublicKey (sdPublicKey sd) - signature = partialParse parseSignature (sdSignature sd) + publicKey = unsafe . parsePublicKey $ sdPublicKey sd + signature = unsafe . parseSignature $ sdSignature sd checkRawSignatureSample :: SignatureData -> Assertion checkRawSignatureSample sd = checkSignature publicKey signature (sdBytes sd) @?= sdValid sd where - publicKey = partialParse parsePublicKeyRaw (unsafeFromHex $ sdPublicKey sd) - signature = partialParse parseSignatureRaw (unsafeFromHex $ sdSignature sd) + publicKey = unsafe . parsePublicKeyRaw . unsafe . fromHex $ sdPublicKey sd + signature = unsafe . parseSignatureRaw . unsafe . fromHex $ sdSignature sd ---------------------------------------------------------------------------- -- Key hashing @@ -266,8 +266,8 @@ hashKeySample :: (Text, Text) -> Assertion hashKeySample (pkText, keyHashText) = hashKey pk @?= keyHash where - pk = partialParse parsePublicKey pkText - keyHash = partialParse parseKeyHash keyHashText + pk = unsafe $ parsePublicKey pkText + keyHash = unsafe $ parseKeyHash keyHashText ---------------------------------------------------------------------------- -- Parsing raw data @@ -278,22 +278,22 @@ [ testCase "Successfully parses valid sample signatures in canonical form" $ forM_ samplePairSignatures (\(a, _) -> bimap STB STB (parseSignature a) `shouldSatisfy` isRight) , testCase "Successfully parses valid sample signatures in raw byte form" $ - forM_ samplePairSignatures (\(_, b) -> fmap STB (parseSignatureRaw . unsafeFromHex $ b) `shouldSatisfy` isRight) + forM_ samplePairSignatures (\(_, b) -> fmap STB (parseSignatureRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight) , testCase "Parsed signatures are equivalent in canonical and raw byte form" $ forM_ samplePairSignatures (\(a, b) -> - (STB . (partialParse parseSignatureRaw) . unsafeFromHex $ b) - @?= (STB . (partialParse parseSignature) $ a)) + (STB . unsafe . parseSignatureRaw . unsafe . fromHex $ b) + @?= (STB . unsafe . parseSignature $ a)) , testGroup "Fails to parse invalid signatures:" [ testCase (toString a) - (parseInvalidSignature a `shouldSatisfy` isNothing) | a <- invalidRawSignatures + (parseInvalidSignature a `shouldSatisfy` isLeft) | a <- invalidRawSignatures ] ] where - parseInvalidSignature :: Text -> Maybe Signature + parseInvalidSignature :: Text -> Either Text Signature parseInvalidSignature a = do bs <- fromHex a - rightToMaybe (parseSignatureRaw bs) + first pretty $ parseSignatureRaw bs samplePairSignatures :: [(Text, Text)] samplePairSignatures = @@ -320,20 +320,20 @@ [ testCase "Successfully parses valid sample public keys in canonical form" $ forM_ sampleRawPublicKeys (\(a, _) -> bimap STB STB (parsePublicKey a) `shouldSatisfy` isRight) , testCase "Successfully parses valid sample public keys in raw byte form" $ - forM_ sampleRawPublicKeys (\(_, b) -> fmap STB (parsePublicKeyRaw . unsafeFromHex $ b) `shouldSatisfy` isRight) + forM_ sampleRawPublicKeys (\(_, b) -> fmap STB (parsePublicKeyRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight) , testCase "Parsed public keys are equivalent in canonical and raw byte form" $ - forM_ sampleRawPublicKeys (\(a, b) -> (STB . (partialParse parsePublicKeyRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parsePublicKey) $ a)) + forM_ sampleRawPublicKeys (\(a, b) -> (STB . unsafe . parsePublicKeyRaw . unsafe . fromHex $ b) @?= (STB . unsafe . parsePublicKey $ a)) , testGroup "Fails to parse invalid public keys:" [ testCase (toString a) - (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawPublicKeys + (parseInvalidKey a `shouldSatisfy` isLeft) | a <- invalidRawPublicKeys ] ] where - parseInvalidKey :: Text -> Maybe PublicKey + parseInvalidKey :: Text -> Either Text PublicKey parseInvalidKey a = do bs <- fromHex a - rightToMaybe (parsePublicKeyRaw bs) + first pretty $ parsePublicKeyRaw bs sampleRawPublicKeys :: [(Text, Text)] sampleRawPublicKeys = @@ -359,19 +359,19 @@ [ testCase "Successfully parses valid sample key hashes in canonical form" $ forM_ sampleRawKeyHashes (\(a, _) -> bimap STB STB (parseKeyHash a) `shouldSatisfy` isRight) , testCase "Successfully parses valid sample key hashes in raw byte form" $ - forM_ sampleRawKeyHashes (\(_, b) -> fmap STB (parseKeyHashRaw . unsafeFromHex $ b) `shouldSatisfy` isRight) + forM_ sampleRawKeyHashes (\(_, b) -> fmap STB (parseKeyHashRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight) , testCase "Parsed key hashes are equivalent in canonical and raw byte form" $ - forM_ sampleRawKeyHashes (\(a, b) -> (STB . (partialParse parseKeyHashRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parseKeyHash) $ a)) + forM_ sampleRawKeyHashes (\(a, b) -> (STB . unsafe . parseKeyHashRaw . unsafe . fromHex $ b) @?= (STB . unsafe . parseKeyHash $ a)) , testGroup "Fails to parse invalid key hashes:" [ testCase (toString a) - (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawKeyHashes + (parseInvalidKey a `shouldSatisfy` isLeft) | a <- invalidRawKeyHashes ] ] where - parseInvalidKey :: Text -> Maybe KeyHash + parseInvalidKey :: Text -> Either Text KeyHash parseInvalidKey a = do bs <- fromHex a - rightToMaybe (parseKeyHashRaw bs) + first pretty $ parseKeyHashRaw bs sampleRawKeyHashes :: [(Text, Text)] sampleRawKeyHashes = diff --git a/morley-test/Test/Tezos/Crypto/BLS12381.hs b/morley-test/Test/Tezos/Crypto/BLS12381.hs --- a/morley-test/Test/Tezos/Crypto/BLS12381.hs +++ b/morley-test/Test/Tezos/Crypto/BLS12381.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Tezos.Crypto.BLS12381'. -- @@ -15,10 +14,10 @@ import Prelude hiding (negate) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Hedgehog (Gen, assert, forAll, property, withTests, (===)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.HUnit ((@?=)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) @@ -27,7 +26,7 @@ import Hedgehog.Gen.Tezos.Crypto.BLS12381 import Morley.Tezos.Crypto.BLS12381 import Morley.Util.Named ((!)) -import Test.Cleveland.Util hiding (fromHex) +import Test.Cleveland.Util test_SerializationRoundtrip :: [TestTree] test_SerializationRoundtrip = @@ -45,45 +44,45 @@ [ testCase "Fr" $ zero @Bls12381Fr @?= -- this and other constants are defined below - unsafeFromMichelsonBytes frZeroValue + unsafe (fromMichelsonBytes frZeroValue) , testCase "G1" $ zero @Bls12381G1 @?= - unsafeFromMichelsonBytes g1ZeroValue + unsafe (fromMichelsonBytes g1ZeroValue) , testCase "G2" $ zero @Bls12381G2 @?= - unsafeFromMichelsonBytes g2ZeroValue + unsafe (fromMichelsonBytes g2ZeroValue) ] , testGroup "One" [ testCase "Fr" $ (1 :: Bls12381Fr) @?= - unsafeFromMichelsonBytes frOneValue + unsafe (fromMichelsonBytes frOneValue) , testCase "G1" $ g1One @?= - unsafeFromMichelsonBytes g1OneValue + unsafe (fromMichelsonBytes g1OneValue) , testCase "G2" $ g2One @?= - unsafeFromMichelsonBytes g2OneValue + unsafe (fromMichelsonBytes g2OneValue) ] , testGroup "Negate one" [ testCase "Fr" $ negate (1 :: Bls12381Fr) @?= - unsafeFromMichelsonBytes frMinusOneValue + unsafe (fromMichelsonBytes frMinusOneValue) , testCase "G1" $ negate g1One @?= - unsafeFromMichelsonBytes g1MinusOneValue + unsafe (fromMichelsonBytes g1MinusOneValue) , testCase "G2" $ negate g2One @?= - unsafeFromMichelsonBytes g2MinusOneValue + unsafe (fromMichelsonBytes g2MinusOneValue) ] @@ -93,11 +92,11 @@ test_SerializationEdgeCases = [ testGroup "Fr" [ testCase "Smaller length" $ - fromMichelsonBytes @Bls12381Fr (unsafeFromHex "0100") + fromMichelsonBytes @Bls12381Fr (unsafe $ fromHex "0100") @?= Right 1 , testCase "Larger length" $ - fromMichelsonBytes @Bls12381Fr (unsafeFromHex $ mconcat $ replicate 33 "00") + fromMichelsonBytes @Bls12381Fr (unsafe . fromHex . mconcat $ replicate 33 "00") @?= Left (TooLargeLength ! #limit 32 ! #given 33) , testCase "Too big bytes value" $ @@ -185,40 +184,40 @@ Just (bs, b) -> BS.snoc bs (b + 1) frMaxBoundPlusOne :: ByteString -frMaxBoundPlusOne = unsafeFromHex "01000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" +frMaxBoundPlusOne = unsafe $ fromHex "01000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" -- Constants (taken from Tezos tests mentioned at the top) ---------------------------------------------------------------------------- g1SomeVal :: ByteString -g1SomeVal = unsafeFromHex "026fcea34d1a4c5125142dfa3b616086309cab49e60e548d95de658af4d9329c269dc132bd5d884617e8767600daeee90c6f5d25f3d63540f3b799d291e5df4a90244346ed780d5c9d3afa8f3c9a196e089fa4edc4a9806592e8561d626579e3" +g1SomeVal = unsafe $ fromHex "026fcea34d1a4c5125142dfa3b616086309cab49e60e548d95de658af4d9329c269dc132bd5d884617e8767600daeee90c6f5d25f3d63540f3b799d291e5df4a90244346ed780d5c9d3afa8f3c9a196e089fa4edc4a9806592e8561d626579e3" g2SomeVal :: ByteString -g2SomeVal = unsafeFromHex "14e9b22683a66543ec447b7aa76e4404424709728507581d0b3f60a8062c3f7c7d3365197c59f7c961fa9731084f5be60d0a936e93d556bdef2032cdcae2fa9902dcbe105e01d7ab7126d83486d882c4efd2fc1ac55044157333be19acf0cb7a10bc41c8081c9babd8d5b41b645badd4a679b3d4e1b3ea2c0e1f53b39c00b3889a40306c9b9ee2da5831e90148334d91016474d07e0f4e36d2d51b5ca11b633b9a940b9c126aebf4a2537c18fdc6967fb677824bfa902157e53cb499a021e57b" +g2SomeVal = unsafe $ fromHex "14e9b22683a66543ec447b7aa76e4404424709728507581d0b3f60a8062c3f7c7d3365197c59f7c961fa9731084f5be60d0a936e93d556bdef2032cdcae2fa9902dcbe105e01d7ab7126d83486d882c4efd2fc1ac55044157333be19acf0cb7a10bc41c8081c9babd8d5b41b645badd4a679b3d4e1b3ea2c0e1f53b39c00b3889a40306c9b9ee2da5831e90148334d91016474d07e0f4e36d2d51b5ca11b633b9a940b9c126aebf4a2537c18fdc6967fb677824bfa902157e53cb499a021e57b" frZeroValue :: ByteString -frZeroValue = unsafeFromHex "0000000000000000000000000000000000000000000000000000000000000000" +frZeroValue = unsafe $ fromHex "0000000000000000000000000000000000000000000000000000000000000000" g1ZeroValue :: ByteString -g1ZeroValue = unsafeFromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" +g1ZeroValue = unsafe $ fromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" g2ZeroValue :: ByteString -g2ZeroValue = unsafeFromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" +g2ZeroValue = unsafe $ fromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" frOneValue :: ByteString -frOneValue = unsafeFromHex "0100000000000000000000000000000000000000000000000000000000000000" +frOneValue = unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000" g1OneValue :: ByteString -g1OneValue = unsafeFromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1" +g1OneValue = unsafe $ fromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1" g2OneValue :: ByteString -g2OneValue = unsafeFromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801" +g2OneValue = unsafe $ fromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801" frMinusOneValue :: ByteString -frMinusOneValue = unsafeFromHex "00000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" +frMinusOneValue = unsafe $ fromHex "00000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" g1MinusOneValue :: ByteString -g1MinusOneValue = unsafeFromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb114d1d6855d545a8aa7d76c8cf2e21f267816aef1db507c96655b9d5caac42364e6f38ba0ecb751bad54dcd6b939c2ca" +g1MinusOneValue = unsafe $ fromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb114d1d6855d545a8aa7d76c8cf2e21f267816aef1db507c96655b9d5caac42364e6f38ba0ecb751bad54dcd6b939c2ca" g2MinusOneValue :: ByteString -g2MinusOneValue = unsafeFromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb813fa4d4a0ad8b1ce186ed5061789213d993923066dddaf1040bc3ff59f825c78df74f2d75467e25e0f55f8a00fa030ed0d1b3cc2c7027888be51d9ef691d77bcb679afda66c73f17f9ee3837a55024f78c71363275a75d75d86bab79f74782aa" +g2MinusOneValue = unsafe $ fromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb813fa4d4a0ad8b1ce186ed5061789213d993923066dddaf1040bc3ff59f825c78df74f2d75467e25e0f55f8a00fa030ed0d1b3cc2c7027888be51d9ef691d77bcb679afda66c73f17f9ee3837a55024f78c71363275a75d75d86bab79f74782aa" diff --git a/morley-test/Test/Tezos/Crypto/Hash.hs b/morley-test/Test/Tezos/Crypto/Hash.hs --- a/morley-test/Test/Tezos/Crypto/Hash.hs +++ b/morley-test/Test/Tezos/Crypto/Hash.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Tezos.Crypto.Hash'. diff --git a/morley-test/Test/Tezos/Crypto/Timelock.hs b/morley-test/Test/Tezos/Crypto/Timelock.hs --- a/morley-test/Test/Tezos/Crypto/Timelock.hs +++ b/morley-test/Test/Tezos/Crypto/Timelock.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Tezos.Crypto.Timelock'. module Test.Tezos.Crypto.Timelock @@ -11,8 +10,8 @@ import Prelude hiding (negate) import Hedgehog (forAll, property, withTests, (===)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) diff --git a/morley-test/Test/Typeable.hs b/morley-test/Test/Typeable.hs --- a/morley-test/Test/Typeable.hs +++ b/morley-test/Test/Typeable.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on 'Morley.Util.Typeable'. module Test.Typeable diff --git a/morley-test/Test/Typecheck.hs b/morley-test/Test/Typecheck.hs --- a/morley-test/Test/Typecheck.hs +++ b/morley-test/Test/Typecheck.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + module Test.Typecheck ( unit_Good_contracts , unit_Bad_contracts @@ -18,13 +20,13 @@ ) where import Data.Default (def) -import qualified Data.Map as M -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) +import Data.Map qualified as M +import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Data.Typeable (typeRep) import Fmt (build, pretty) import Hedgehog (Gen, Property, evalNF, forAll, property, (===)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.HUnit (Assertion, assertFailure, (@?=)) import Test.Hspec (expectationFailure) import Test.Hspec.Expectations (Expectation) @@ -35,15 +37,17 @@ import Hedgehog.Gen.Michelson.Typed import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..), srcPos) import Morley.Michelson.Parser (MichelsonSource(..), utypeQ) -import Morley.Michelson.Runtime (prepareContract) +import Morley.Michelson.Runtime (prepareContractExt) import Morley.Michelson.Text (MText) import Morley.Michelson.TypeCheck -import qualified Morley.Michelson.Typed as T -import Morley.Michelson.Untyped (ParameterType(..), noAnn, unsafeBuildEpName) -import qualified Morley.Michelson.Untyped as Un +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped (ParameterType(..), buildEpName, noAnn) +import Morley.Michelson.Untyped qualified as Un import Morley.Tezos.Address (Address(..), mkContractHashHack) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature) +import Morley.Util.Interpolate (itu) +import Morley.Util.MismatchError import Test.Cleveland.Michelson (failedTest, meanTimeUpperBoundPropNF, sec) import Test.Cleveland.Michelson.Import (ContractReadError(..), readContract) @@ -81,7 +85,7 @@ checkIllFile (inContractsDir "ill-typed/macro_in_let_fail.mtz") $ \case TCFailedOnInstr (Un.COMPARE _) _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 7) (Pos 6))) _ - (Just (TypeEqError _ _)) -> True + (Just (TypeEqError _)) -> True _ -> False checkIllFile (inContractsDir "ill-typed/compare_annotation_mismatch.tz") $ \case TCFailedOnInstr (Un.COMPARE _) _ _ _ (Just (AnnError _)) -> True @@ -128,18 +132,18 @@ -> (TCError -> Expectation) -> Expectation checkFile wellTyped file options onError = do - c <- prepareContract (Just file) + c <- prepareContractExt (Just file) case typeCheckingWith options $ typeCheckContract c of Left err | wellTyped -> expectationFailure $ - "Typechecker unexpectedly failed on " <> show file <> - ": " <> displayException err + "Typechecker unexpectedly failed on \"" <> file <> + "\": " <> displayException err | otherwise -> onError err Right _ | not wellTyped -> assertFailure $ - "Typechecker unexpectedly considered " <> show file <> " well-typed." + "Typechecker unexpectedly considered \"" <> file <> "\" well-typed." | otherwise -> pass checkIllFile :: FilePath -> (TCError -> Bool) -> Expectation @@ -251,12 +255,20 @@ -- avoiding silly errors like lost spaces and ensuring general sanity -- of used way to display content. [ testCase "TypeEqError" $ - build (TypeEqError T.TUnit T.TKey) - @?= "Types not equal: unit /= key" + build (TypeEqError MkMismatchError{meActual=T.TUnit, meExpected=T.TKey}) + @?= [itu| + Types not equal: + Expected: key + Actual: unit + |] , testCase "StackEqError" $ - build (StackEqError [T.TUnit, T.TBytes] []) - @?= "Stacks not equal: [unit, bytes] /= []" + build (StackEqError $ MkMismatchError{meExpected=[T.TUnit, T.TBytes], meActual=[]}) + @?= [itu| + Stacks not equal: + Expected: [unit, bytes] + Actual: [] + |] , testCase "UnsupportedTypes" $ build (UnsupportedTypeForScope (T.TBigMap T.TInt T.TInt) T.BtHasBigMap) @@ -287,15 +299,15 @@ [ testCase "Nested seq with different levels of nesting can't be typechecked as list" $ case runTC $ typeCheckValue @('T.TList ('T.TList 'T.TInt)) illTypedList of Left _ -> pass - Right other -> assertFailure $ "Unexpected result: " <> show other + Right other -> assertFailure $ "Unexpected result: " <> pretty other , testCase "Nested seq with the same levels of nesting can be typechecked as list" $ case runTC $ typeCheckValue @('T.TList ('T.TList 'T.TInt)) wellTypedList of Right _ -> pass - Left err -> assertFailure $ "Unexpected error: " <> show err + Left err -> assertFailure $ "Unexpected error: " <> pretty err , testCase "Nested seq with different levels of nesting can be typechecked as lambda" $ case runTC $ typeCheckValue @('T.TLambda 'T.TInt 'T.TInt) wellTypedLambda of Right _ -> pass - Left err -> assertFailure $ "Unexpected error: " <> show err + Left err -> assertFailure $ "Unexpected error: " <> pretty err ] test_SELF :: [TestTree] @@ -322,31 +334,34 @@ typeVerifyParameter @('T.TContract 'T.TUnit) mempty addrUVal1 of Left (TCFailedOnValue _ _ _ _ (Just (UnknownContract _))) -> pass - res -> assertFailure $ "Unexpected result: " <> show res + res -> assertFailure $ "Unexpected result: " <> either pretty pretty res , testCase "Entrypoint does not exist" $ case typeCheckingWith def $ typeVerifyParameter @('T.TContract 'T.TKey) env1 addrUVal1 of Left (TCFailedOnValue _ _ _ _ (Just (EntrypointNotFound _))) -> pass - res -> assertFailure $ "Unexpected result: " <> show res + res -> assertFailure $ "Unexpected result: " <> either pretty pretty res , testCase "Correct contract value" $ case typeCheckingWith def $ typeVerifyParameter @('T.TContract 'T.TInt) env1 addrUVal2 of Right _ -> pass - res -> assertFailure $ "Unexpected result: " <> show res + res -> assertFailure $ "Unexpected result: " <> either pretty pretty res ] where addr1' = mkContractHashHack "123" - addr1 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "a") - addr2 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "q") + addr1 = T.EpAddress (ContractAddress addr1') . unsafe $ buildEpName "a" + addr2 = T.EpAddress (ContractAddress addr1') . unsafe $ buildEpName "q" addrUVal1 = Un.ValueString $ T.mformatEpAddress addr1 addrUVal2 = Un.ValueString $ T.mformatEpAddress addr2 env1 = M.fromList - [ ( addr1', unsafeMkSomeParamType $ ParameterType [utypeQ| ( nat %s | int %q ) |] noAnn) + [ ( addr1', + unsafe . mkSomeParamType + $ ParameterType [utypeQ| or (nat %s) (int %q) |] noAnn + ) ] test_Views :: [TestTree] diff --git a/morley-test/Test/Typecheck/Annotation.hs b/morley-test/Test/Typecheck/Annotation.hs --- a/morley-test/Test/Typecheck/Annotation.hs +++ b/morley-test/Test/Typecheck/Annotation.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Typecheck.Annotation ( test_variableAnnotations @@ -13,6 +12,7 @@ import Data.Default (def) import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos) +import Morley.Michelson.Parser (notes) import Morley.Michelson.Typed import Morley.Michelson.Untyped (noAnn) import Test.Cleveland.Instances () @@ -25,14 +25,13 @@ let file = inContractsDir ("tezos_examples" "attic" "cadr_annotation.tz") param = "param" no_name = "no_name" - p1 = "p1" name = "name" contract <- importContract @('TPair ('TPair 'TUnit 'TString) 'TBool) @'TUnit file stripVarAnn (cCode contract) @?= - loc 2 7 (withNotes (NTPair noAnn p1 noAnn noAnn noAnn (NTPair noAnn noAnn no_name noAnn noAnn starNotes starNotes) starNotes) (AnnCAR param noAnn)) + loc 2 7 (withNotes [notes|pair (pair %p1 unit (string %no_name)) bool|] (AnnCAR param noAnn)) `Seq` Nested ( - withNotes (NTPair noAnn noAnn no_name noAnn noAnn starNotes starNotes) (AnnCAR noAnn noAnn) + withNotes [notes|pair unit (string %no_name)|] (AnnCAR noAnn noAnn) `Seq` AnnCDR name no_name) `Seq` loc 2 40 DROP `Seq` loc 2 46 UNIT diff --git a/morley-test/Test/Untyped/Instr.hs b/morley-test/Test/Untyped/Instr.hs --- a/morley-test/Test/Untyped/Instr.hs +++ b/morley-test/Test/Untyped/Instr.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for 'Morley.Michelson.Untyped.Instr'. diff --git a/morley-test/Test/Util/Hedgehog.hs b/morley-test/Test/Util/Hedgehog.hs --- a/morley-test/Test/Util/Hedgehog.hs +++ b/morley-test/Test/Util/Hedgehog.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {- Copyright (c) 2017 IOHK @@ -36,12 +35,14 @@ , aesonRoundtrip ) where +import Debug qualified (show) + import Data.Aeson (FromJSON(..), ToJSON(..)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Fmt (Buildable, pretty) import Hedgehog (Gen) import Test.Tasty (TestTree) -import qualified Text.Show (show) +import Text.Show qualified (show) import Test.Cleveland.Util (roundtripTree) @@ -58,7 +59,7 @@ show = pretty . unSTB instance Show (ShowThroughBuild ByteString) where - show = show . unSTB + show = Debug.show . unSTB genShowThroughBuild :: Gen a -> Gen (ShowThroughBuild a) genShowThroughBuild genA = STB <$> genA diff --git a/morley-test/Test/Util/Parser.hs b/morley-test/Test/Util/Parser.hs --- a/morley-test/Test/Util/Parser.hs +++ b/morley-test/Test/Util/Parser.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Util.Parser ( shouldParse @@ -11,10 +10,10 @@ import Text.Megaparsec (errorBundlePretty) import Morley.Michelson.Parser (Parser, codeSrc) -import qualified Morley.Michelson.Parser as Parser +import Morley.Michelson.Parser qualified as Parser -- | Expect the given text to be successfully parsed. -shouldParse :: HasCallStack => Parser a -> Text -> IO a +shouldParse :: HasCallStack => Parser () a -> Text -> IO a shouldParse parser text = case Parser.parseNoEnv parser codeSrc text of Left err -> diff --git a/morley-test/Test/Util/TH.hs b/morley-test/Test/Util/TH.hs new file mode 100644 --- /dev/null +++ b/morley-test/Test/Util/TH.hs @@ -0,0 +1,78 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Test.Util.TH + ( shouldCompileTo + , shouldCompileIgnoringInstance + ) where + +import Prelude hiding (Type) + +import Data.Generics qualified as SYB +import Language.Haskell.TH (pprint) +import Language.Haskell.TH.Syntax + (Dec(..), Name, Q, TyVarBndr(..), Type(..), mkName, nameBase, runQ) +import Test.Tasty.HUnit (Assertion, (@?=)) +import Text.Show qualified (show) + +---------------------------------------------------------------------------- +-- TemplateHaskell test helpers +---------------------------------------------------------------------------- + +shouldCompileTo :: HasCallStack => [Dec] -> Q [Dec] -> Assertion +shouldCompileTo actualDecs expectedQ = do + expectedDecs <- runQ expectedQ + PrettyDecs (normalizeDecs actualDecs) @?= PrettyDecs (normalizeDecs expectedDecs) + +-- | Same as 'shouldCompileTo', but ignores instance declarations of the given class. +shouldCompileIgnoringInstance :: HasCallStack => Name -> [Dec] -> Q [Dec] -> Assertion +shouldCompileIgnoringInstance className actualDecs expectedQ = do + expectedDecs <- runQ expectedQ + let actualDecs' = filter (not . isInstance) actualDecs + PrettyDecs (normalizeDecs actualDecs') @?= PrettyDecs (normalizeDecs expectedDecs) + + where + isInstance :: Dec -> Bool + isInstance = \case + InstanceD _ _ (ConT t `AppT` _) _ | t == className -> True + _ -> False + +-- | Normalize ASTs to make them comparable. +-- +-- By default, quoted ASTs and ASTs with names created using 'newName' will have +-- names with unique IDs. +-- For example: +-- +-- > decs <- runQ [d|data D = D { f :: Int } |] +-- > putStrLn $ pprint decs +-- > +-- > -- Will generate this AST: +-- > data D_0 = D_1 { f_2 :: Int } +-- +-- To be able to check if two ASTs are equivalent, we have to scrub the unique IDs off all names. +-- +-- For convenience, to make the output easier to read, we also erase kind annotations when the kind is '*'. +normalizeDecs :: [Dec] -> [Dec] +normalizeDecs decs = + SYB.everywhere + (SYB.mkT fixName . SYB.mkT simplifyType . SYB.mkT simplifyTyVar) + decs + where + fixName :: Name -> Name + fixName = mkName . nameBase + + simplifyType :: Type -> Type + simplifyType = \case + SigT t StarT -> t + t -> t + + simplifyTyVar :: TyVarBndr -> TyVarBndr + simplifyTyVar = \case + KindedTV name StarT -> PlainTV name + tv -> tv + +newtype PrettyDecs = PrettyDecs [Dec] + deriving newtype Eq + +instance Show PrettyDecs where + show (PrettyDecs decs) = pprint decs diff --git a/morley-test/Test/ValConversion.hs b/morley-test/Test/ValConversion.hs --- a/morley-test/Test/ValConversion.hs +++ b/morley-test/Test/ValConversion.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Testing of toVal / fromVal conversions @@ -10,8 +9,8 @@ ) where import Hedgehog (Gen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.HUnit (Assertion, (@?)) import Test.Tasty (TestTree) diff --git a/morley-test/Test/Views.hs b/morley-test/Test/Views.hs --- a/morley-test/Test/Views.hs +++ b/morley-test/Test/Views.hs @@ -1,14 +1,11 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on views-related primitives. module Test.Views ( test_ViewsSets ) where -import Fmt (pretty) - import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) @@ -19,7 +16,7 @@ dummyView :: HasCallStack => Text -> Integer -> View 'TUnit 'TUnit 'TUnit dummyView name id' = View - { vName = unsafeMkViewName name + { vName = unsafe $ mkViewName name , vArgument = starNotes , vReturn = starNotes , vCode = dummyViewCode id' @@ -38,7 +35,7 @@ , testCase "Duplicate views cause failure" $ mkViewsSet [dummySomeView "a" 1, dummySomeView "b" 2, dummySomeView "a" 3] - @?= Left (DuplicatedViewName (unsafeMkViewName "a")) + @?= Left (DuplicatedViewName (unsafe $ mkViewName "a")) ] @@ -55,24 +52,24 @@ >>= addViewToSet (dummyView "a" 1) >>= addViewToSet (dummyView "b" 2) >>= addViewToSet (dummyView "a" 3) - ) @?= Left (DuplicatedViewName (unsafeMkViewName "a")) + ) @?= Left (DuplicatedViewName (unsafe $ mkViewName "a")) ] , testGroup "Lookup" - let viewsSet1 = either (error . pretty) id $ mkViewsSet + let viewsSet1 = unsafe $ mkViewsSet [ dummySomeView "" 0 , dummySomeView "a" 1 ] in [ testCase "Can find a present view" $ do - lookupView (unsafeMkViewName "") viewsSet1 + lookupView (unsafe $ mkViewName "") viewsSet1 @?= Just (dummySomeView "" 0) - lookupView (unsafeMkViewName "a") viewsSet1 + lookupView (unsafe $ mkViewName "a") viewsSet1 @?= Just (dummySomeView "a" 1) , testCase "Fail to find a non-existent view" $ - lookupView (unsafeMkViewName "x") viewsSet1 + lookupView (unsafe $ mkViewName "x") viewsSet1 @?= Nothing ] diff --git a/src/Hedgehog/Gen/Michelson.hs b/src/Hedgehog/Gen/Michelson.hs --- a/src/Hedgehog/Gen/Michelson.hs +++ b/src/Hedgehog/Gen/Michelson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Michelson ( genInstrCallStack @@ -12,11 +11,11 @@ import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) -import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, unsafeMkMText) +import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, mkMText) genInstrCallStack :: MonadGen m => m InstrCallStack genInstrCallStack = InstrCallStack <$> genLetCallStack <*> genSrcPos @@ -38,6 +37,6 @@ genMText :: MonadGen m => m MText genMText = - unsafeMkMText <$> Gen.text + unsafe . mkMText <$> Gen.text (Range.linear 0 100) (Gen.enum (toEnum @Char minBoundMChar) (toEnum @Char maxBoundMChar)) diff --git a/src/Hedgehog/Gen/Michelson/Typed.hs b/src/Hedgehog/Gen/Michelson/Typed.hs --- a/src/Hedgehog/Gen/Michelson/Typed.hs +++ b/src/Hedgehog/Gen/Michelson/Typed.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -22,26 +21,25 @@ , genSimpleInstr ) where -import qualified Control.Exception as Ex +import Control.Exception qualified as Ex import Data.Singletons (Sing) import Hedgehog (GenBase, MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Hedgehog.Gen.Michelson.Untyped (genEpName) import Hedgehog.Gen.Tezos.Address (genAddress) import Hedgehog.Gen.Tezos.Core (genChainId, genMutez, genTimestamp) import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSignature) import Hedgehog.Gen.Tezos.Crypto.BLS12381 (genBls12381Fr, genBls12381G1, genBls12381G2) -import Morley.Michelson.Text (unsafeMkMText) +import Morley.Michelson.Text (mkMText) import Morley.Michelson.Typed - (Comparable, Instr(DROP, FAILWITH, PUSH, SWAP, Seq, UNIT), SingT(..), T(..), Value'(..), - WellTyped, toVal) + (Instr(DROP, FAILWITH, PUSH, SWAP, Seq, UNIT), SingT(..), T(..), Value'(..), toVal) import Morley.Michelson.Typed.Entrypoints (EpAddress(..), unsafeSepcCallRoot) import Morley.Michelson.Typed.Haskell.Value (BigMap(..), BigMapId(..), ToT, WellTypedToT) import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Value (RemFail(..)) -import qualified Morley.Tezos.Crypto.BLS12381 as BLS +import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Hedgehog.Gen.Tezos.Crypto.Timelock (genChestAndKey) @@ -142,7 +140,7 @@ <*> Gen.map (Range.linear 0 100) (liftA2 (,) (genNoOpValue k) (genNoOpValue v)) STInt -> genValueInt STNat -> VNat <$> Gen.integral (Range.linearFrom 0 0 1000) - STString -> VString . unsafeMkMText . fromString <$> Gen.string (Range.linear 0 100) Gen.alphaNum + STString -> VString . unsafe . mkMText . fromString <$> Gen.string (Range.linear 0 100) Gen.alphaNum STBytes -> VBytes <$> Gen.bytes (Range.linear 0 100) STMutez -> genValueMutez STKeyHash -> genValueKeyHash @@ -156,6 +154,8 @@ STChest -> VChest . fst <$> genChestAndKey STChestKey -> VChestKey . snd <$> genChestAndKey STNever -> Gen.discard + STSaplingState _ -> error "genValue': Cannot generate `sapling_state` value." + STSaplingTransaction _ -> error "genValue': Cannot generate `sapling_instruction` value." where genNoOpValue :: (MonadGen m, GenBase m ~ Identity, WellTyped t') diff --git a/src/Hedgehog/Gen/Michelson/Untyped.hs b/src/Hedgehog/Gen/Michelson/Untyped.hs --- a/src/Hedgehog/Gen/Michelson/Untyped.hs +++ b/src/Hedgehog/Gen/Michelson/Untyped.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + module Hedgehog.Gen.Michelson.Untyped ( genInternalByteString , genVar @@ -30,10 +32,10 @@ import Prelude hiding (EQ, GT, LT) -import qualified Data.Text as T +import Data.Text qualified as T import Hedgehog (MonadGen(GenBase), Range) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Michelson.Untyped @@ -154,6 +156,7 @@ , ISNAT <$> genAnnotation , ADD <$> genAnnotation , SUB <$> genAnnotation + , SUB_MUTEZ <$> genAnnotation , MUL <$> genAnnotation , EDIV <$> genAnnotation , ABS <$> genAnnotation @@ -210,7 +213,7 @@ genEntriesOrder = Gen.enumBounded genViewName :: (MonadGen m, GenBase m ~ Identity) => m ViewName -genViewName = unsafeMkViewName <$> Gen.text +genViewName = unsafe . mkViewName <$> Gen.text (Range.linear 0 viewNameMaxLength) (Gen.filter isValidViewNameChar Gen.ascii) diff --git a/src/Hedgehog/Gen/Morley/Micheline.hs b/src/Hedgehog/Gen/Morley/Micheline.hs --- a/src/Hedgehog/Gen/Morley/Micheline.hs +++ b/src/Hedgehog/Gen/Morley/Micheline.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Morley.Micheline ( genExpression @@ -10,8 +9,8 @@ ) where import Hedgehog (MonadGen(GenBase)) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Hedgehog.Gen.Michelson.Untyped (genAnnotation) import Morley.Micheline.Expression diff --git a/src/Hedgehog/Gen/SizedList.hs b/src/Hedgehog/Gen/SizedList.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/SizedList.hs @@ -0,0 +1,25 @@ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Hedgehog.Gen.SizedList + ( genSizedList + , genSomeSizedList + ) where + + +import Hedgehog (MonadGen) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types + +genSizedList + :: forall n m a n'. (SingIPeano n, IsoNatPeano n n', MonadGen m) + => m a -> m (SizedList' n' a) +genSizedList el = sequence $ pure el + +genSomeSizedList + :: forall m a. (MonadGen m) + => Range.Range Int -> m a -> m (SomeSizedList a) +genSomeSizedList len el = SL.fromList <$> Gen.list len el diff --git a/src/Hedgehog/Gen/Tezos/Address.hs b/src/Hedgehog/Gen/Tezos/Address.hs --- a/src/Hedgehog/Gen/Tezos/Address.hs +++ b/src/Hedgehog/Gen/Tezos/Address.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Address in Tezos. @@ -11,8 +10,8 @@ ) where import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Hedgehog.Gen.Tezos.Crypto (genKeyHash) import Morley.Tezos.Address (Address(..), ContractHash(..)) diff --git a/src/Hedgehog/Gen/Tezos/Core.hs b/src/Hedgehog/Gen/Tezos/Core.hs --- a/src/Hedgehog/Gen/Tezos/Core.hs +++ b/src/Hedgehog/Gen/Tezos/Core.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Core ( genChainId @@ -16,12 +15,12 @@ import Data.Time.Clock (UTCTime(..)) import Data.Time.Format (defaultTimeLocale, parseTimeM) import Hedgehog (MonadGen, Range) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Core - (ChainId(..), Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, - timestampToSeconds, unsafeMkMutez) + (ChainId(..), Mutez(..), Timestamp, mkMutez, timestampFromSeconds, timestampFromUTCTime, + timestampToSeconds) import Test.Cleveland.Instances () @@ -34,7 +33,7 @@ -- | Generates an arbitrary `Mutez` value constrained to the given range. genMutez' :: MonadGen m => Range Mutez -> m Mutez -genMutez' range = unsafeMkMutez <$> Gen.word64 (unMutez <$> range) +genMutez' range = unsafe . mkMutez <$> Gen.word64 (fromIntegral . unMutez <$> range) genTimestamp :: MonadGen m => m Timestamp genTimestamp = diff --git a/src/Hedgehog/Gen/Tezos/Crypto.hs b/src/Hedgehog/Gen/Tezos/Crypto.hs --- a/src/Hedgehog/Gen/Tezos/Crypto.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto ( genPublicKey @@ -11,16 +10,16 @@ ) where import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto (KeyHash, KeyHashTag, PublicKey, SecretKey(..), Signature(..), hashKey, signatureLengthBytes, toPublic) -import qualified Hedgehog.Gen.Tezos.Crypto.Ed25519 as Ed25519 -import qualified Hedgehog.Gen.Tezos.Crypto.P256 as P256 -import qualified Hedgehog.Gen.Tezos.Crypto.Secp256k1 as Secp256k1 +import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519 +import Hedgehog.Gen.Tezos.Crypto.P256 qualified as P256 +import Hedgehog.Gen.Tezos.Crypto.Secp256k1 qualified as Secp256k1 genPublicKey :: MonadGen m => m PublicKey genPublicKey = toPublic <$> genSecretKey diff --git a/src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs b/src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs --- a/src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto.BLS12381 ( genBls12381Fr @@ -9,7 +8,7 @@ ) where import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen qualified as Gen import Morley.Tezos.Crypto.BLS12381 import Test.Cleveland.Util diff --git a/src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs b/src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs --- a/src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto.Ed25519 ( genPublicKey @@ -9,8 +8,8 @@ ) where import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto.Ed25519 (PublicKey, SecretKey, Signature, detSecretKey, sign, toPublic) diff --git a/src/Hedgehog/Gen/Tezos/Crypto/P256.hs b/src/Hedgehog/Gen/Tezos/Crypto/P256.hs --- a/src/Hedgehog/Gen/Tezos/Crypto/P256.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto/P256.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto.P256 ( genPublicKey @@ -10,8 +9,8 @@ import Crypto.Random (drgNewSeed, seedFromInteger, withDRG) import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto.P256 (PublicKey, SecretKey, Signature, detSecretKey, detSecretKeyDo, sign, toPublic) diff --git a/src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs b/src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs --- a/src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto.Secp256k1 ( genPublicKey @@ -10,8 +9,8 @@ import Crypto.Random (drgNewSeed, seedFromInteger, withDRG) import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto.Secp256k1 (PublicKey, SecretKey, Signature, detSecretKey, detSecretKeyDo, sign, toPublic) diff --git a/src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs b/src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs --- a/src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Tezos.Crypto.Timelock ( genChestAndKey @@ -9,8 +8,8 @@ ) where import Hedgehog (MonadGen) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto.Timelock @@ -18,7 +17,7 @@ genChestAndKey = fst <$> genChestAndKeyWithParams Nothing genTLTime :: MonadGen m => m TLTime -genTLTime = unsafeMkTLTime <$> Gen.word64 (Range.linear 1000 10000) +genTLTime = toTLTime <$> Gen.word16 (Range.linear 1000 10000) genChestAndKeyWithParams :: MonadGen m diff --git a/src/Lorentz/Test/DupableScan.hs b/src/Lorentz/Test/DupableScan.hs new file mode 100644 --- /dev/null +++ b/src/Lorentz/Test/DupableScan.hs @@ -0,0 +1,116 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Test utilities to ensure the proper layout of non-dupable elements +-- within datatypes. +module Lorentz.Test.DupableScan + ( CheckDupablesDistribution + , VerifyDupablesDistribution + , checkDupablesDistribution + , testDupablesDistribution + , BadElement (..) + ) where + +import Data.Singletons.Prelude (demote) +import Data.Typeable (TypeRep, typeRep) +import Fmt (Buildable(..), pretty, (+|), (|+)) +import GHC.Generics qualified as G +import Test.HUnit (assertFailure) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) + +import Lorentz +import Morley.Michelson.Typed.Scope +import Morley.Util.Type +import Morley.Util.TypeLits + +-- | Bind on 'Either's that return nothing. +type SumEithers :: Either l () -> Either l () -> Either l r +type family SumEithers e1 e2 where + SumEithers ('Right '()) e = e + SumEithers ('Left err) _ = 'Left err + +-- | Check that the given generic subtree /corresponding to a product part/ +-- contains only elements of given dupability (all dupable or all non-dupable). +type family GCheckDupability (expectedDupability :: Bool) (x :: Type -> Type) + :: Either (Bool, Maybe Symbol, Type) () where + GCheckDupability dup (x G.:*: y) = + GCheckDupability dup x `SumEithers` GCheckDupability dup y + GCheckDupability dup (G.S1 ('G.MetaSel mname _ _ _) (G.Rec0 a)) = + If (IsDupableScope (ToT a) == dup) + ('Right '()) + ('Left '(dup, mname, a)) + +-- | A "generics" helper for 'CheckDupablesDistribution'. +type family GCheckDupablesDistribution (x :: Type -> Type) where + GCheckDupablesDistribution (G.D1 _ (G.C1 _ (l G.:*: r))) = + GCheckDupability 'True l `SumEithers` GCheckDupability 'False r + GCheckDupablesDistribution _ = + TypeError ('Text "This works only on product types") + +-- | For the given type, check that at the left subtree of pairs tree it +-- contains only dupable elements, and at the right - only non-dupable ones. +type family CheckDupablesDistribution (a :: Type) :: Either (Bool, Maybe Symbol, Type) () where + CheckDupablesDistribution a = GCheckDupablesDistribution (G.Rep a) + +-- | Error for 'checkDupablesDistribution'. +data BadElement = BadElement + { beExpectedDupability :: Bool + , beRecName :: Maybe Text + , beRecType :: TypeRep + } deriving stock (Show, Eq) + +instance Buildable BadElement where + build (BadElement expectedDupable recName recType) = + "Expected " <> if expectedDupable then "dupable" else "non-dupable" <> "element \ + \in record field " +| (recName ?: "") |+ " of type " +| show @Text recType |+ "" + +class DemoteRes (res :: Either (Bool, Maybe Symbol, Type) ()) where + demoteRes :: Either BadElement () +instance DemoteRes ('Right '()) where + demoteRes = Right () +instance (SingI dup, SingI mname, Typeable ty) => DemoteRes ('Left '(dup, mname, ty)) where + demoteRes = Left BadElement + { beExpectedDupability = demote @dup + , beRecName = demote @mname + , beRecType = typeRep (Proxy @ty) + } + +-- | 'CheckDupablesDistribution' for term-level. +checkDupablesDistribution + :: forall a. (DemoteRes (CheckDupablesDistribution a)) + => Either BadElement () +checkDupablesDistribution = demoteRes @(CheckDupablesDistribution a) + +-- | A term-level version of 'VerifyDupablesDistribution' for tests. +testDupablesDistribution + :: forall a. (Typeable a, DemoteRes (CheckDupablesDistribution a)) + => TestTree +testDupablesDistribution = + testCase ("Dupables distribution for " <> show (typeRep $ Proxy @a)) $ + case checkDupablesDistribution @a of + Right () -> pass + Left err -> assertFailure $ "Bad dupables distribution: " <> pretty err + +type family ResToConstraint (res :: Either (Bool, Maybe Symbol, Type) ()) :: Constraint where + ResToConstraint ('Right '()) = () + ResToConstraint ('Left '(expectedDup, recName, recType)) = + TypeError + ( 'Text "Expected " ':<>: 'Text (DupableDesc expectedDup) ':<>: 'Text " element" ':$$: + 'Text "in record field " ':<>: 'ShowType (GetMaybeName recName) + ':<>: 'Text " of type " ':<>: 'ShowType recType + ) + +type family DupableDesc (dup :: Bool) :: Symbol where + DupableDesc 'True = "dupable" + DupableDesc 'False = "non-dupable" + +type family GetMaybeName (mname :: Maybe Symbol) :: Symbol where + GetMaybeName ('Just name) = name + GetMaybeName 'Nothing = "" + +-- | A constraint that, for the given type, checks that at the left subtree +-- of pairs tree it contains only dupable elements, and at the right - only +-- non-dupable ones. +type VerifyDupablesDistribution a = + ResToConstraint (CheckDupablesDistribution a) diff --git a/src/Test/Cleveland.hs b/src/Test/Cleveland.hs --- a/src/Test/Cleveland.hs +++ b/src/Test/Cleveland.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Michelson contracts testing on a real Tezos network. -- @@ -44,6 +43,7 @@ , refillable , newAddress , newFreshAddress + , enumAliasHints , signBytes , signBinary , originate @@ -84,12 +84,15 @@ , getNow , getLevel , getApproximateBlockInterval + , RunCode(..) + , AsRPC.MaybeRPC(..) + , runCode , branchout , offshoot , setVotingPowers - , getRunMode - , RunMode (..) , whenEmulation + , whenNetwork + , ifEmulation , inBatch -- * Primitives re-exports @@ -152,17 +155,19 @@ -- * Config (reexports) , TezosClientEnv(..) - , Client.MorleyClientEnv - , Client.MorleyClientEnv'(..) + , MorleyClientEnv + , MorleyClientEnv'(..) , NetworkEnv (..) , MorleyLogs + -- ** Config utilities + , mkMorleyOnlyRpcEnvNetwork -- * AsRPC - , Client.AsRPC - , Client.deriveRPC - , Client.deriveRPCWithStrategy - , Client.deriveManyRPC - , Client.deriveManyRPCWithStrategy + , AsRPC.HasRPCRepr(AsRPC) + , AsRPC.deriveRPC + , AsRPC.deriveRPCWithStrategy + , AsRPC.deriveManyRPC + , AsRPC.deriveManyRPCWithStrategy -- * Utilities , mapEach @@ -170,7 +175,8 @@ ) where import Lorentz (EntrypointRef(..), pattern DefEpName) -import qualified Morley.Client as Client +import Morley.AsRPC qualified as AsRPC +import Morley.Client (MorleyClientEnv, MorleyClientEnv'(..)) import Morley.Client.TezosClient.Types (TezosClientEnv(..)) import Morley.Michelson.Interpret (MorleyLogs) import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap) diff --git a/src/Test/Cleveland/Doc.hs b/src/Test/Cleveland/Doc.hs --- a/src/Test/Cleveland/Doc.hs +++ b/src/Test/Cleveland/Doc.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Utilities for testing documentations sanity. -- diff --git a/src/Test/Cleveland/Doc/Common.hs b/src/Test/Cleveland/Doc/Common.hs --- a/src/Test/Cleveland/Doc/Common.hs +++ b/src/Test/Cleveland/Doc/Common.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Utilities for testing documentations sanity. -- @@ -24,14 +23,14 @@ , buildMarkdownDocTest ) where -import qualified Data.List as L +import Data.List qualified as L import Fmt (Buildable(..), pretty) import GHC.Stack (SrcLoc) import Test.HUnit (Assertion, assertFailure) import Test.HUnit.Lang (HUnitFailure(..)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Text.Show +import Text.Show qualified import Morley.Michelson.Doc diff --git a/src/Test/Cleveland/Doc/Lorentz.hs b/src/Test/Cleveland/Doc/Lorentz.hs --- a/src/Test/Cleveland/Doc/Lorentz.hs +++ b/src/Test/Cleveland/Doc/Lorentz.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Testing predicates for documentation of Lorentz contracts. module Test.Cleveland.Doc.Lorentz @@ -19,7 +18,7 @@ ) where import Data.Typeable (typeRep) -import Fmt (Buildable(..), blockListF, fmt, nameF, (+||), (||+)) +import Fmt (Buildable(..), blockListF, fmt, nameF, (+|), (|+)) import Test.HUnit (assertBool, assertFailure) import Lorentz.Entrypoints.Doc @@ -179,7 +178,7 @@ -- if they appear outside of all entrypoints | isInternalErrorClass (errorDocClass @err) -> pass | otherwise -> assertFailure . fmt $ - "Found an error `" +|| typeRep (Proxy @err) ||+ "` \ + "Found an error `" +| show @Text (typeRep (Proxy @err)) |+ "` \ \thrown outside of any entrypoint.\n\n\ \If this should not belong to any existing entrypoint,\n\ \consider marking the code as common for other entrypoints using\n\ diff --git a/src/Test/Cleveland/Doc/Michelson.hs b/src/Test/Cleveland/Doc/Michelson.hs --- a/src/Test/Cleveland/Doc/Michelson.hs +++ b/src/Test/Cleveland/Doc/Michelson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Testing predicates for documentation of Michelson contracts module Test.Cleveland.Doc.Michelson @@ -17,7 +16,7 @@ , module Test.Cleveland.Doc.Common ) where -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Lazy.Builder (toLazyText) import Fmt (blockListF, fmt, nameF) import Test.HUnit (assertBool, assertFailure) @@ -108,7 +107,7 @@ let res = allContractDocItems contractDoc <&> \(DDescription desc) -> check (toText $ toLazyText desc) - in case nonEmpty . catMaybes $ leftToMaybe <$> res of + in case nonEmpty (lefts res) of Nothing -> pass Just errs -> assertFailure . fmt $ "Some descripions are not well formatted:\n" <> blockListF errs diff --git a/src/Test/Cleveland/Ingredients.hs b/src/Test/Cleveland/Ingredients.hs --- a/src/Test/Cleveland/Ingredients.hs +++ b/src/Test/Cleveland/Ingredients.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Ingredients that we use in our test suites. diff --git a/src/Test/Cleveland/Instances.hs b/src/Test/Cleveland/Instances.hs --- a/src/Test/Cleveland/Instances.hs +++ b/src/Test/Cleveland/Instances.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -8,19 +7,22 @@ ( HasInstrCallStack (..) ) where -import Fmt (Buildable(..), tupleF) -import qualified GHC.Num (fromInteger) -import Morley.Michelson.Text (MText, unsafeMkMText) +import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+)) +import GHC.Num qualified (fromInteger) +import Test.Tasty.Runners (FailureReason(..)) +import Time (Time) + +import Morley.Michelson.Text (MText, mkMText) import Morley.Michelson.Typed.Haskell.Value (BigMap(..)) -import qualified Morley.Michelson.Untyped as U -import Morley.Michelson.Untyped.Annotation (Annotation(..), unsafeMkAnnotation) -import Morley.Tezos.Core (Mutez(..), unsafeAddMutez, unsafeMkMutez, unsafeMulMutez, unsafeSubMutez) +import Morley.Michelson.Untyped qualified as U +import Morley.Michelson.Untyped.Annotation (Annotation(..), mkAnnotation) +import Morley.Tezos.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez) instance IsString (Annotation tag) where - fromString = unsafeMkAnnotation . toText + fromString = unsafe . mkAnnotation . toText instance IsString MText where - fromString = unsafeMkMText . toText + fromString = unsafe . mkMText . toText instance Num Mutez where @@ -30,11 +32,11 @@ (*) a b = unsafeMulMutez a $ fromIntegral $ unMutez b - abs = unsafeMkMutez . abs . unMutez + abs = unsafe . mkMutez . abs . unMutez - signum = unsafeMkMutez . signum . unMutez + signum = unsafe . mkMutez . signum . unMutez - fromInteger = unsafeMkMutez . fromInteger + fromInteger = unsafe . mkMutez @Word64 . fromInteger deriving newtype instance Real Mutez deriving newtype instance Integral Mutez @@ -68,10 +70,29 @@ instance (Eq k, Eq v) => Eq (BigMap k v) where BigMap _ bm1 == BigMap _ bm2 = bm1 == bm2 +instance Buildable () where build _ = "()" + instance (Buildable a, Buildable b) => Buildable (a, b) where build = tupleF -instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where build = tupleF -instance (Buildable a, Buildable b, Buildable c, Buildable d) => Buildable (a, b, c, d) where build = tupleF +instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where + build = tupleF +instance (Buildable a, Buildable b, Buildable c, Buildable d) => + Buildable (a, b, c, d) where build = tupleF +instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e) => + Buildable (a, b, c, d, e) where build = tupleF +instance (Buildable a, Buildable b, Buildable c, + Buildable d, Buildable e, Buildable f) => + Buildable (a, b, c, d, e, f) where build = tupleF +instance (Buildable a, Buildable b, Buildable c, + Buildable d, Buildable e, Buildable f, + Buildable g) => Buildable (a, b, c, d, e, f, g) where build = tupleF +instance (Buildable a, Buildable b, Buildable c, + Buildable d, Buildable e, Buildable f, + Buildable g, Buildable h) => + Buildable (a, b, c, d, e, f, g, h) where build = tupleF +instance Buildable ByteString where build bs = "0x" <> hexF bs +instance Buildable LByteString where build bs = "0x" <> hexF bs + -- | Class of types with t'Morley.Michelson.ErrorPos.InstrCallStack' allowing to remove it. -- Can be used in tests when we want to compare only values without callstack. class HasInstrCallStack a where @@ -108,3 +129,17 @@ withoutIcs = \case U.ValueLambda ops -> U.ValueLambda $ withoutIcs' ops v -> v + +-- We don't want to depend on o-clock in morley-prelude, hence we're defining +-- the instance here. +type instance PrettyShow (Time _) = () + +instance Buildable FailureReason where + build = \case + TestFailed -> "Test failed" + TestThrewException e -> "Test threw exception: " +| displayException e |+ "" + TestTimedOut s -> "Test timed out: " +| s |+ "" + TestDepFailed -> "Test skipped because its dependency failed" + +instance (Buildable a, Buildable b) => Buildable (Either a b) where + build = eitherF diff --git a/src/Test/Cleveland/Internal/Abstract.hs b/src/Test/Cleveland/Internal/Abstract.hs --- a/src/Test/Cleveland/Internal/Abstract.hs +++ b/src/Test/Cleveland/Internal/Abstract.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Abstract cleveland interface not bound to a particular -- implementation. @@ -36,8 +35,8 @@ , Sender (..) , Moneybag (..) , UntypedOriginateData (..) - , BaseOperationData (..) - , BaseOperationResult (..) + , RunCode(..) + , ClevelandInput , DefaultAliasCounter (..) , SpecificOrDefaultAliasHint (..) @@ -77,8 +76,11 @@ -- * Capability records , ClevelandCaps(..) , EmulatedCaps(..) - , RunMode(..) , HasClevelandCaps(..) + , senderL + , moneybagL + , getMiscCap + , getOpsCap , HasEmulatedCaps(..) , MonadCleveland @@ -107,20 +109,23 @@ import Lorentz (Contract(..)) import Lorentz.Constraints -import Morley.Client (Alias, AliasHint) +import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC) +import Morley.Client (Alias, AliasHint, Result) +import Morley.Client.Types import Morley.Micheline (Expression, fromExpression) import Morley.Michelson.ErrorPos (InstrCallStack) import Morley.Michelson.Interpret (MorleyLogs(..)) import Morley.Michelson.Runtime (VotingPowers) import Morley.Michelson.Typed (BigMapId) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.AnnotatedValue (SomeAnnotatedValue) import Morley.Michelson.Typed.Entrypoints import Morley.Michelson.Typed.Scope (ConstantScope) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Core (ChainId, Mutez, Timestamp) -import qualified Morley.Tezos.Crypto as Crypto +import Morley.Tezos.Crypto +import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Batching import Morley.Util.Sing (eqI) import Morley.Util.TypeLits @@ -171,15 +176,12 @@ -- for transfers to key addresses. } --- | Datatype specifying creation of arbitrary operation. -data BaseOperationData - = OriginateOp UntypedOriginateData - | TransferOp TransferData - --- | Datatype specifying result of operation run. -data BaseOperationResult - = OriginateResult Address - | TransferResult +-- | Designates an operation input. +data ClevelandInput +instance OperationInfoDescriptor ClevelandInput where + type TransferInfo ClevelandInput = TransferData + type OriginationInfo ClevelandInput = UntypedOriginateData + type RevealInfo ClevelandInput = PublicKey -- | A batch returned invalid output, e.g. origination address when transaction -- was supplied. @@ -234,11 +236,12 @@ -- | Counter which is used to provide different default aliases. newtype DefaultAliasCounter = DefaultAliasCounter {unDefaultAliasCounter :: Natural} + deriving stock Show -- | A record data type with operations creating primitives. data ClevelandOpsImpl m = ClevelandOpsImpl { coiRunOperationBatch - :: HasCallStack => [BaseOperationData] -> m [BaseOperationResult] + :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo Result] -- ^ Perform a batch of operations. } @@ -279,7 +282,7 @@ -- Returns 'Nothing' when the big_map ID does not exist, or it exists but -- does not contain the given key. , cmiGetAllBigMapValuesMaybe - :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v) + :: forall k v. (HasCallStack, NiceComparable k, NiceUnpackedValue v) => BigMapId k v -> m (Maybe [v]) -- ^ Retrieve all big_map values, given a big_map ID. -- Returns 'Nothing' when the big_map ID does not exist. @@ -317,8 +320,28 @@ , cmiMarkAddressRefillable :: Address -> m () -- ^ Marks a given address as "refillable", i.e. if the address lacks funds for the next operation, -- some funds will automatically be transferred to it. + , cmiEmulatedImpl :: m (Maybe (EmulatedImpl m)) + -- ^ Produce 'EmulatedImpl' if possible. Used to run emulated actions in polymorphic context. + , cmiRunCode + :: forall cp st vd. (HasCallStack, HasRPCRepr st, T.IsoValue (AsRPC st)) + => Sender -> RunCode cp st vd -> m (AsRPC st) + -- ^ Execute a contract's code without originating it. + -- The chain's state will not be modified. } +-- | The data needed to call the @/run_code@ RPC endpoint. +data RunCode cp st vd = RunCode + { rcContract :: Contract cp st vd + , rcStorage :: MaybeRPC st + , rcParameter :: MaybeRPC cp + , rcAmount :: Mutez + -- ^ The value that will be returned by the @AMOUNT@ instruction. + , rcBalance :: Mutez + -- ^ The balance that will be returned by the @BALANCE@ instruction. + , rcSource :: Maybe Address + -- ^ The value that will be returned by the @SOURCE@ instruction. + } + -- | A record data type with all base methods one can use during cleveland, but which are available -- only when running on an emulated environment (e.g. "Morley.Michelson.Runtime") and not on a real network. data EmulatedImpl m = EmulatedImpl @@ -398,7 +421,7 @@ -- @-XApplicativeDo@ extension for nicer experience. newtype ClevelandOpsBatch a = ClevelandOpsBatch { unClevelandOpsBatch - :: BatchingM BaseOperationData BaseOperationResult Void a + :: BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) Void a } deriving newtype (Functor, Applicative) instance @@ -452,7 +475,7 @@ :: (HasCallStack, Buildable e, Functor m) => Proxy e -> ClevelandOpsImpl m - -> BatchingM BaseOperationData BaseOperationResult e a + -> BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) e a -> m a runOperationBatchM _ impl = fmap snd . unsafeRunBatching (fmap ((), ) . coiRunOperationBatch impl) @@ -462,8 +485,8 @@ :: (HasCallStack, Functor m) => ClevelandOpsImpl m -> Text - -> BaseOperationData - -> (BaseOperationResult -> Maybe a) + -> OperationInfo ClevelandInput + -> (OperationInfo Result -> Maybe a) -> m a runSingleOperation impl desc opData parseRes = runOperationBatchM (Proxy @BatchResultMismatch) impl $ @@ -540,8 +563,7 @@ instance Buildable TransferFailureReason where build = \case - FailedWith expr loc -> "failed with: " +| expr |+ - maybe "" (" at " +|) (build <$> loc) + FailedWith expr loc -> "failed with: " +| expr |+ maybe "" ((" at " +|) . build) loc EmptyTransaction -> "Attempted to transfer 0tz to a simple address" BadParameter -> "parameter of the wrong type" MutezArithError typ -> "mutez " +| typ |+ "" @@ -595,7 +617,7 @@ -- It is intentionally here and not in some deeper module because the -- name is really short and more suitable for writing scenarios. ep :: HasCallStack => Text -> EpName -ep = U.unsafeBuildEpName +ep = unsafe . U.buildEpName -- | Runs a handler over every action. mapClevelandOpsImplExceptions @@ -635,6 +657,8 @@ , cmiAttempt = \action -> cmiAttempt action , cmiMarkAddressRefillable = f . cmiMarkAddressRefillable , cmiThrow = cmiThrow + , cmiEmulatedImpl = f $ cmiEmulatedImpl + , cmiRunCode = f ... cmiRunCode } -- | A record with all the capabilities available to any cleveland test. @@ -654,23 +678,12 @@ makeLensesFor [("ccSender", "ccSenderL"), ("ccMoneybag", "ccMoneybagL")] ''ClevelandCaps makeLensesFor [("ecClevelandCaps", "ecClevelandCapsL")] ''EmulatedCaps --- | In which mode the test suite is currently executed. -data RunMode caps where - -- | Test is run on-chain. - NetworkMode :: RunMode caps - -- | Test is run in Morley emulation. - EmulationMode :: HasEmulatedCaps caps => RunMode caps - -- | A proof that the given @caps@ record contains -- the basic cleveland capabilities. class Monad (ClevelandBaseMonad caps) => HasClevelandCaps caps where -- | This will be either @PureM@ or @ClientM@. type ClevelandBaseMonad caps :: Type -> Type - senderL :: Lens' caps Sender - moneybagL :: Lens' caps Moneybag - getMiscCap :: caps -> ClevelandMiscImpl (ClevelandBaseMonad caps) - getOpsCap :: caps -> ClevelandOpsImpl (ClevelandBaseMonad caps) - runMode :: RunMode caps + clevelandCapsL :: Lens' caps (ClevelandCaps (ClevelandBaseMonad caps)) -- | A proof that the given @caps@ record contains -- the basic cleveland capabilities + the emulator capabiilities. @@ -679,19 +692,23 @@ instance Monad m => HasClevelandCaps (ClevelandCaps m) where type ClevelandBaseMonad (ClevelandCaps m) = m - senderL = ccSenderL - moneybagL = ccMoneybagL - getMiscCap = ccMiscCap - getOpsCap r = ccOpsCap r (r ^. senderL) - runMode = NetworkMode + clevelandCapsL = id instance Monad m => HasClevelandCaps (EmulatedCaps m) where type ClevelandBaseMonad (EmulatedCaps m) = m - senderL = ecClevelandCapsL . senderL - moneybagL = ecClevelandCapsL . moneybagL - getMiscCap = getMiscCap . ecClevelandCaps - getOpsCap = getOpsCap . ecClevelandCaps - runMode = EmulationMode + clevelandCapsL = ecClevelandCapsL + +senderL :: HasClevelandCaps caps => Lens' caps Sender +senderL = clevelandCapsL . ccSenderL + +moneybagL :: HasClevelandCaps caps => Lens' caps Moneybag +moneybagL = clevelandCapsL . ccMoneybagL + +getMiscCap :: HasClevelandCaps caps => caps -> ClevelandMiscImpl (ClevelandBaseMonad caps) +getMiscCap = ccMiscCap . view clevelandCapsL + +getOpsCap :: HasClevelandCaps caps => caps -> ClevelandOpsImpl (ClevelandBaseMonad caps) +getOpsCap r = ccOpsCap (r ^. clevelandCapsL) (r ^. senderL) instance Monad m => HasEmulatedCaps (EmulatedCaps m) where getEmulatedCap = ecEmulatedCap diff --git a/src/Test/Cleveland/Internal/Actions.hs b/src/Test/Cleveland/Internal/Actions.hs --- a/src/Test/Cleveland/Internal/Actions.hs +++ b/src/Test/Cleveland/Internal/Actions.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Cleveland actions. module Test.Cleveland.Internal.Actions @@ -12,6 +11,7 @@ , refillable , newAddress , newFreshAddress + , enumAliasHints , signBytes , signBinary , originate @@ -51,13 +51,15 @@ , getNow , getLevel , getApproximateBlockInterval + , runCode , branchout , offshoot , getDelegate , registerDelegate , setVotingPowers - , getRunMode , whenEmulation + , whenNetwork + , ifEmulation -- * Assertions , failure @@ -105,41 +107,52 @@ import Data.Constraint (Dict(Dict), (\\)) import Data.Either.Validation (Validation(..)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Singletons (demote) import Fmt (Buildable, Builder, build, indentF, nameF, pretty, unlinesF, (+|), (|+)) import Time (KnownDivRat, Second, Time) -import qualified Unsafe (fromIntegral) +import Unsafe qualified (fromIntegral) import Lorentz (BigMapId, Contract(..), CustomError(..), DemoteViewsDescriptor, ErrorTagMap, HasEntrypointArg(useHasEntrypointArg), IsError, IsoValue, Label, MText, MustHaveErrorArg, ToTAddress, errorTagToMText, errorToVal, errorToValNumeric, noViews, pattern DefEpName, - toMichelsonContract, toMutez, toTAddress, toVal, zeroMutez) + toMichelsonContract, toTAddress, toVal, zeroMutez) import Lorentz.Bytes import Lorentz.Constraints -import Morley.Client (Alias, AsRPC) +import Morley.AsRPC (HasRPCRepr(..)) +import Morley.Client (Alias, OperationInfo(..)) import Morley.Micheline (Expression, FromExpression(..), toExpression) import Morley.Michelson.Printer.Util (buildRenderDoc) import Morley.Michelson.Runtime (VotingPowers) -import qualified Morley.Michelson.Runtime.Import as Runtime +import Morley.Michelson.Runtime.Import qualified as Runtime import Morley.Michelson.Typed - (SomeAnnotatedValue, SomeConstant(..), ToT, convertContract, untypeValue) -import qualified Morley.Michelson.Typed as T + (SomeAnnotatedValue, SomeConstant, SomeConstrainedValue(..), convertContract, untypeValue) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature) +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types import Test.Cleveland.Internal.Abstract -import qualified Test.Cleveland.Internal.Client as Client (TestError(..)) +import Test.Cleveland.Internal.Client qualified as Client (TestError(..)) import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Internal.Pure as Pure (TestError(..)) -import qualified Test.Cleveland.Lorentz.Import as LorentzImport +import Test.Cleveland.Lorentz.Import qualified as LorentzImport import Test.Cleveland.Lorentz.Types {-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} +-- $setup +-- >>> :m +Morley.Util.SizedList.Types +-- >>> :{ +-- isEquivalentTo :: Show a => a -> a -> Bool +-- isEquivalentTo a b = show a == show b +-- infix 0 `isEquivalentTo` +-- :} + -- | Typeclass for monads where operations-related actions can occur. -- -- This is implemented for 'MonadCleveland' and batch context. @@ -224,9 +237,9 @@ -- The address may exist from previous scenarios runs and have sufficient -- balance for the sake of testing; if so, we can save some time balance <- getBalance addr - when (balance < toMutez 0.5_e6) do -- < 0.5 XTZ + when (balance < 0.5_e6) do -- < 0.5 XTZ withSender moneybag do - transferMoney addr (toMutez 0.9_e6) -- 0.9 XTZ + transferMoney addr 0.9_e6 -- 0.9 XTZ pure addr -- | Generate a new secret key and record it with given alias. If the @@ -251,6 +264,18 @@ signBytes bytes signer = do withCap getMiscCap \cap -> cmiSignBytes cap bytes signer +-- | Create a list of similarly named 'SpecificAliasHint's. +-- +-- For example, +-- +-- >>> enumAliasHints @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil +-- True +enumAliasHints + :: forall n n'. + (SingIPeano n, IsoNatPeano n n') + => AliasHint -> SizedList n SpecificOrDefaultAliasHint +enumAliasHints pfx = SpecificAliasHint <$> SL.generate @n (\n -> pfx <> "-" <> show n) + -- | Type-safer version of 'signBytes'. signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs) signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr @@ -258,8 +283,8 @@ -- | Originate a new raw Michelson contract with given data. originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address originateUntyped uod = withOpsCap \opsCap -> - runSingleOperation opsCap "origination" (OriginateOp uod) \case - OriginateResult addr -> Just addr + runSingleOperation opsCap "origination" (OpOriginate uod) \case + OpOriginate addr -> Just addr _ -> Nothing -- | A simplified version of the originateUntyped command. @@ -304,7 +329,7 @@ :: forall cp st vd m. ( HasCallStack , MonadOps m - , NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd + , NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd ) => AliasHint -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd) originateTypedSimple name storage contract@T.Contract{} = do @@ -360,8 +385,8 @@ -- you need the semantics of both in one operation. transfer :: (HasCallStack, MonadOps m) => TransferData -> m () transfer td = withOpsCap \opsCap -> - runSingleOperation opsCap "transfer" (TransferOp td) \case - TransferResult -> Just () + runSingleOperation opsCap "transfer" (OpTransfer td) \case + OpTransfer () -> Just () _ -> Nothing -- | Simply transfer money to an address. @@ -383,7 +408,8 @@ -- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'. call :: forall param vd addr m epRef epArg. - (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg, IsoValue epArg, Typeable epArg) + (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg + , IsoValue epArg, Typeable epArg) => addr -> epRef -> epArg @@ -407,7 +433,7 @@ -- The compiler must be able to infer the types of parameter, storage and views. -- In case there are no views or you don't care, you can use 'noViews'. importContract - :: ( HasCallStack, NiceParameterFull param, NiceStorage st + :: ( HasCallStack, NiceParameter param, NiceStorage st , NiceViewsDescriptor vd, DemoteViewsDescriptor vd , MonadCleveland caps m ) @@ -469,14 +495,15 @@ -- | Retrieve a contract's storage in its "RPC representation" -- (i.e., all its big_maps will be replaced by big_map IDs). -- --- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' / 'Test.Cleveland.deriveManyRPC' --- should be used to create an RPC representation of the storage type. +-- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' / +-- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage +-- type. -- -- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText } -- > deriveRPC "MyStorage" getStorage :: forall st addr caps m. - (HasCallStack, MonadCleveland caps m, ToStorageType st addr, NiceUnpackedValue (AsRPC st)) + (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st)) => addr -> m (AsRPC st) getStorage contract = do @@ -485,7 +512,7 @@ Just st -> pure st Nothing -> failure $ unlinesF [ "Expected storage to be of type:" - , indentF 2 $ build $ demote @(ToT (AsRPC st)) + , indentF 2 $ build $ demote @(T.ToT (AsRPC st)) , "But its type was:" , indentF 2 $ build $ getT someSt ] @@ -548,7 +575,7 @@ getAllBigMapValuesMaybe :: forall k v caps m. ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + , NiceComparable k, NiceUnpackedValue v ) => BigMapId k v -> m (Maybe [v]) getAllBigMapValuesMaybe bmId = do @@ -558,7 +585,7 @@ getAllBigMapValues :: forall k v caps m. ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + , NiceComparable k, NiceUnpackedValue v ) => BigMapId k v -> m [v] getAllBigMapValues bmId = @@ -573,7 +600,7 @@ getBigMapSizeMaybe :: forall k v caps m. ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + , NiceComparable k, NiceUnpackedValue v ) => BigMapId k v -> m (Maybe Natural) getBigMapSizeMaybe bmId = @@ -583,7 +610,7 @@ getBigMapSize :: forall k v caps m. ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + , NiceComparable k, NiceUnpackedValue v ) => BigMapId k v -> m Natural getBigMapSize bmId = @@ -646,6 +673,25 @@ getApproximateBlockInterval = do withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap +-- | Execute a contract's code without originating it. +-- The chain's state will not be modified. +-- +-- Notes: +-- +-- * If the contract's code emits operations, they will not be executed. +-- * The sender's account won't be debited. +-- * When running an _originated_ contract, the @BALANCE@ instruction returns the +-- sum of the contract's balance before the transfer operation + the amount of tz being transferred. +-- In other words, this invariant holds: @BALANCE >= AMOUNT@. +-- However, since `runCode` allows overriding the @BALANCE@ instruction, +-- then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@. +runCode + :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st)) + => RunCode cp st vd -> m (AsRPC st) +runCode rc = do + sender <- view senderL + withCap getMiscCap \cap -> cmiRunCode cap sender rc + -- | Execute multiple testing scenarios independently. -- -- * Actions performed before 'branchout' will be observed by all branches. @@ -674,8 +720,8 @@ offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m () offshoot branchName branch = branchout [(branchName, branch)] -{- | Returns the result of the action with the logs it produced. Logs are messages printed by the morley instruction -[@PRINT@](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/language/morleyInstructions.md#print) +{- | Returns the result of the action with the logs it produced. Logs are messages +printed by the Lorentz instruction 'Lorentz.printComment'. This function can be combined either with lens-based accessors or helper functions to get more specific information about logs. @@ -711,31 +757,49 @@ setVotingPowers vp = do withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp --- | Check at runtime whether the test is being run against a network or the emulator. --- --- Note that if you write a test suite that is executed in both modes, --- with this function you can conditionally perform some emulation-only actions. --- --- @ --- getRunMode >>= \case --- NetworkMode -> do --- ... --- EmulationMode -> do --- ... --- @ -getRunMode :: forall caps m. MonadCleveland caps m => m (RunMode caps) -getRunMode = pure runMode +-- | A helper constraint synonym to make signatures below a bit shorter +type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b -- | Perform an action if we are currently in emulation mode. --- whenEmulation +-- See also 'ifEmulation' note on constraints. whenEmulation - :: HasClevelandCaps caps - => (HasEmulatedCaps caps => ReaderT caps (ClevelandBaseMonad caps) ()) - -> ReaderT caps (ClevelandBaseMonad caps) () -whenEmulation action = getRunMode >>= \case - NetworkMode -> pass - EmulationMode -> action + :: MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ()) + -> m () +whenEmulation action = ifEmulation action pass +-- | Perform an action if we are currently in network mode. +-- See also 'ifEmulation' note on constraints. +whenNetwork + :: MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 ()) + -> m () +whenNetwork action = ifEmulation pass action + +{- | Perform one action if we are currently in emulation mode, another otherwise + +Functions passed as the first two arguments are universally quantified over +the outer monad, so if additional constraints are required beyond +'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base +monad, e.g. + +@ +someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m () +someFunction = whenEmulation do + Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail + runIO $ print x +@ +-} +ifEmulation + :: forall a caps m + . MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a) + -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 a) + -> m a +ifEmulation onEmu onNet = withCap getMiscCap cmiEmulatedImpl >>= \case + Nothing -> onNet + Just impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl) + ---------------------------------------------------------------------------- -- Assertions ---------------------------------------------------------------------------- @@ -871,7 +935,8 @@ Left err -> return err Right _ -> runIO $ throwM UnexpectedSuccess --- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the exception. +-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the +-- exception. -- -- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $ -- > call contractAddr (Call @"Ep") arg @@ -925,21 +990,24 @@ , ")" ] --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant value. +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant +-- value. expectFailedWith :: forall err a caps m . (HasCallStack, MonadCleveland caps m, NiceConstant err) => err -> m a -> m () expectFailedWith err = expectTransferFailure $ failedWith (constant err) --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz error. +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz +-- error. expectError :: forall err a caps m . (HasCallStack, MonadCleveland caps m, IsError err) => err -> m a -> m () expectError err = expectTransferFailure $ failedWith (lerror err) --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom lorentz error. +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom +-- lorentz error. expectCustomError :: forall arg a tag caps m . ( HasCallStack, MonadCleveland caps m @@ -967,7 +1035,8 @@ => Label tag -> m a -> m () expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag) --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz numeric error. +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz +-- numeric error. expectNumericError :: forall err a caps m . (HasCallStack, MonadCleveland caps m, IsError err) @@ -1074,7 +1143,8 @@ -- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error. -- --- This function should be used together with one of the "@FAILWITH@ constructors" (e.g. 'constant', 'customError'). +-- This function should be used together with one of the "@FAILWITH@ constructors" +-- (e.g. 'constant', 'customError'). failedWith :: SomeConstant -> TransferFailurePredicate failedWith expectedFailWithVal = transferFailureReasonPredicate \case FailedWith (EOTVExpression actualFailWithExpr) _ diff --git a/src/Test/Cleveland/Internal/Client.hs b/src/Test/Cleveland/Internal/Client.hs --- a/src/Test/Cleveland/Internal/Client.hs +++ b/src/Test/Cleveland/Internal/Client.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Implementation that works with real Tezos network, it -- talks to a Tezos node and uses @tezos-client@. @@ -22,6 +21,7 @@ -- * Environment , NetworkEnv (..) + , mkMorleyOnlyRpcEnvNetwork -- * Lens for 'NetworkEnv' , neMorleyClientEnvL @@ -32,43 +32,49 @@ , InternalNetworkScenarioError(..) ) where -import Control.Lens -import qualified Data.Aeson.Text as J +import Control.Lens (_head, each, filtered, makeLensesWith) +import Data.Aeson.Text qualified as J import Data.Constraint (withDict, (\\)) import Data.Default (def) import Data.Ratio ((%)) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, secondsToNominalDiffTime) import Fmt (Buildable(build), Builder, indentF, pretty, unlinesF, (+|), (|+)) import System.IO (hFlush) import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit) -import qualified Unsafe (fromIntegral) +import Unsafe qualified (fromIntegral) import Lorentz (NicePackedValue, toAddress) +import Lorentz qualified as L import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi) +import Morley.AsRPC (AsRPC, HasRPCRepr(..), MaybeRPC(..), TAsRPC, notesAsRPC, rpcSingIEvi) import Morley.Client - (AddressOrAlias(..), Alias, MorleyClientEnv, disableAlphanetWarning, runMorleyClientM) -import qualified Morley.Client as Client + (AddressOrAlias(..), Alias, MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, + runMorleyClientM) +import Morley.Client qualified as Client +import Morley.Client.Action (Result) +import Morley.Client.Action.Reveal qualified as RevealRPC +import Morley.Client.Init qualified as Client import Morley.Client.Logging (logInfo, logWarning) -import Morley.Client.RPC.AsRPC (AsRPC, notesAsRPC, rpcSingIEvi) -import qualified Morley.Client.RPC.Error as RPC (ClientRpcError(..), RunCodeErrors(..)) +import Morley.Client.RPC.Error qualified as RPC (ClientRpcError(..), RunCodeErrors(..)) import Morley.Client.RPC.Types (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp), BlockId(..), OperationHash, OriginationScript(..), ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize)) +import Morley.Client.Util qualified as Client import Morley.Micheline (Expression, FromExpression(fromExpression), MichelinePrimitive(..), StringEncode(..), TezosInt64, - TezosMutez(unTezosMutez), _ExpressionPrim, _ExpressionSeq, mpaArgsL, mpaPrimL) + TezosMutez(..), _ExpressionPrim, _ExpressionSeq, mpaArgsL, mpaPrimL) import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed (BigMapId, SomeAnnotatedValue(..), SomeContractAndStorage(..), toVal) -import qualified Morley.Michelson.Typed as T -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Typed qualified as T +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address, mkKeyAddress) import Morley.Tezos.Core as Tezos - (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMkMutez, - unsafeMulMutez, unsafeSubMutez) + (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez, + unsafeSubMutez) import Morley.Tezos.Crypto -import qualified Morley.Tezos.Crypto as Crypto +import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Exception import Morley.Util.Lens (postfixLFields) import Morley.Util.Named @@ -84,6 +90,19 @@ makeLensesWith postfixLFields ''NetworkEnv +-- | Construct 'Client.MorleyOnlyRpcEnv' from 'NetworkEnv'. +mkMorleyOnlyRpcEnvNetwork + :: NetworkEnv + -> [SecretKey] -- ^ Extra secrets that should be known + -> Client.MorleyOnlyRpcEnv +mkMorleyOnlyRpcEnvNetwork NetworkEnv{..} extraSecrets = + Client.MorleyOnlyRpcEnv + { moreLogAction = Client.mkLogAction 0 + , moreClientEnv = Client.mceClientEnv neMorleyClientEnv + , moreSecretKeys = mconcat + [ one (mkKeyAddress (toPublic sk), sk) + | sk <- maybe id (:) neSecretKey extraSecrets ] + } -- | This error designates that necessary preparations for running tests -- are not made. @@ -131,7 +150,7 @@ { unClientM :: ReaderT (IORef ClientState) IO a } deriving newtype (Functor, Applicative, Monad, MonadIO, - MonadThrow, MonadCatch, MonadReader (IORef ClientState)) + MonadThrow, MonadCatch, MonadReader (IORef ClientState), MonadFail) data InternalNetworkScenarioError = TooManyRefillIterations Word Address deriving stock (Show) @@ -219,6 +238,7 @@ alias <- Client.getAlias (Client.AddressResolved addr) Client.registerDelegate (Client.AnAlias alias) Nothing , cmiComment = comment + , cmiEmulatedImpl = pure Nothing , .. } where @@ -267,7 +287,7 @@ storageType <- getStorageType osCode T.withUType storageType \(storageNotes :: T.Notes t) -> do withDict (rpcSingIEvi @t) do - case fromExpression @(T.Value (AsRPC t)) osStorage of + case fromExpression @(T.Value (TAsRPC t)) osStorage of Right storageValueRPC -> pure $ SomeAnnotatedValue (notesAsRPC storageNotes) storageValueRPC Left err -> @@ -346,6 +366,32 @@ when (targetLevel > curLevel) $ threadDelay (sec 1) >> go go + cmiRunCode + :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st)) + => Sender -> RunCode cp st vd -> ClientM (AsRPC st) + cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcBalance rcSource) = + liftIO $ runMorleyClientM env do + -- Pattern match on the contract constructor to reveal + -- a proof of `NiceParameter cp` and `NiceStorage st` + L.Contract{} <- pure rcContract + T.fromVal <$> Client.runContract Client.RunContractParameters + { rcpContract = L.toMichelsonContract $ rcContract + , rcpStorage = + case rcStorage of + NotRPC v -> NotRPC $ toVal v + IsRPC v -> IsRPC $ toVal v + , rcpParameter = + case rcParameter of + NotRPC v -> NotRPC $ toVal v + IsRPC v -> IsRPC $ toVal v + , rcpAmount = rcAmount + , rcpBalance = rcBalance + , rcpSource = rcSource + , rcpSender = Just sender + } + \\ L.niceParameterEvi @cp + \\ L.niceStorageEvi @st + comment :: Text -> ClientM () comment msg = liftIO $ putTextLn msg >> hFlush stdout @@ -361,7 +407,7 @@ bc <- liftIO $ runMorleyClientM env (Client.getBlockConstants HeadId) pure . Unsafe.fromIntegral @Int64 @Natural . bhnhLevel $ bcHeader bc -runOperationBatch :: MorleyClientEnv -> Address -> [BaseOperationData] -> ClientM [BaseOperationResult] +runOperationBatch :: MorleyClientEnv -> Address -> [OperationInfo ClevelandInput] -> ClientM [OperationInfo Result] runOperationBatch env sender ops = do istRef <- ask ClientState{csMoneybagAddress=Moneybag moneybag} <- readIORef istRef @@ -371,10 +417,15 @@ liftIO $ revealKeyUnlessRevealed env sender ops' <- forM ops \case - OriginateOp uod -> - Right <$> convertOriginateUntypedData uod - TransferOp td -> - pure . Left $ convertTransferData td + OpOriginate uod -> + OpOriginate <$> convertOriginateUntypedData uod + OpTransfer td -> + pure . OpTransfer $ convertTransferData td + OpReveal key -> + pure $ OpReveal RevealRPC.RevealData + { rdPublicKey = key + , rdMbFee = Nothing + } let refill :: Word -> Client.MorleyClientM Word refill iter = do @@ -384,7 +435,8 @@ when (iter > 3) $ throwM $ TooManyRefillIterations iter sender realBalance <- Client.getBalance sender let handleRunErrors errs' - | Just (required, balance) <- findBalanceTooLow errs' = do + | Just (arg #balance -> balance, arg #required -> required) + <- findBalanceTooLow errs' = do logInfo $ sender |+ " balance of " +| realBalance |+ " \n\ \is too low, need " +| required |+ ", but got " +| balance |+ "" let reportedDifference = unsafeSubMutez required balance @@ -424,8 +476,8 @@ void $ Client.lTransfer moneybag sender amount U.DefEpName () Nothing refill (iter + 1) -- loop addSafetyMutez x = fromMaybe x $ addMutez x safetyMutez - minimalMutez = unsafeMkMutez 5e5 - safetyMutez = unsafeMkMutez 100 + minimalMutez = 5e5 + safetyMutez = 100 safetyStorage = 20 approximateRequired balance = do -- dry-run as moneybag and estimate cost+burn+fees @@ -437,14 +489,15 @@ -- anyway. let totalFees = unsafeSumMutez fees unsafeSumMutez = foldr unsafeAddMutez zeroMutez - zeroMutez = unsafeMkMutez 0 + zeroMutez = 0 originationSz = Unsafe.fromIntegral @Int @Natural ppOriginationSize (opsSum, originationSize) = bimap unsafeSumMutez sum . unzip $ map opcostAndOriginationCount ops costPerByte = unTezosMutez ppCostPerByte opcostAndOriginationCount = \case - OriginateOp uod -> (uodBalance uod, originationSz) - TransferOp td -> (tdAmount td, 0) + OpOriginate uod -> (uodBalance uod, originationSz) + OpTransfer td -> (tdAmount td, 0) + OpReveal _ -> (zeroMutez, 0) storageDiff AppliedResult{..} = safetyStorage + Unsafe.fromIntegral @TezosInt64 @Natural arPaidStorageDiff storageBurnInBytes = originationSize + sum (map storageDiff appliedResults) storageBurnInMutez = unsafeMulMutez costPerByte storageBurnInBytes @@ -462,33 +515,28 @@ "Refill of " +| sender |+ " took " +| tookIters |+ " iterations." snd <$> Client.runOperations (AddressResolved sender) ops' - let results' = results <&> \case - Left () -> - TransferResult - Right addr -> - OriginateResult addr - - forM_ results' $ \case - OriginateResult addr -> do + forM_ results $ \case + OpTransfer () -> pass + OpOriginate addr -> do alias <- getAlias env addr comment $ "Originated smart contract '" +| alias |+ "' with address " <> pretty addr - _ -> pass + OpReveal () -> pass - return results' + return results dryRunOperations :: AddressOrAlias - -> [Either Client.TransactionData Client.OriginationData] + -> [OperationInfo Client.ClientInput] -> Client.MorleyClientM [(AppliedResult, Mutez)] dryRunOperations s = \case [] -> return [] (x:xs) -> toList . map (second unTezosMutez) <$> Client.dryRunOperationsNonEmpty s (x :| xs) -findBalanceTooLow :: [Client.RunError] -> Maybe (Mutez, Mutez) +findBalanceTooLow :: [Client.RunError] -> Maybe ("balance" :! Mutez, "required" :! Mutez) -- we really shouldn't get several errors of the same type here, so find only the first one findBalanceTooLow - (Client.BalanceTooLow (N balance) (N required):_) - = Just (required, balance) + (Client.BalanceTooLow balance required:_) + = Just (balance, required) findBalanceTooLow (_:xs) = findBalanceTooLow xs findBalanceTooLow [] = Nothing diff --git a/src/Test/Cleveland/Internal/Exceptions.hs b/src/Test/Cleveland/Internal/Exceptions.hs --- a/src/Test/Cleveland/Internal/Exceptions.hs +++ b/src/Test/Cleveland/Internal/Exceptions.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module defines common exception types and exception-related functions -- used throughout the "Test.Cleveland" modules. diff --git a/src/Test/Cleveland/Internal/Hedgehog.hs b/src/Test/Cleveland/Internal/Hedgehog.hs --- a/src/Test/Cleveland/Internal/Hedgehog.hs +++ b/src/Test/Cleveland/Internal/Hedgehog.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Hedgehog-related helpers module Test.Cleveland.Internal.Hedgehog @@ -12,12 +11,12 @@ import Data.Char (isSpace) import Data.Coerce (coerce) import Data.List (dropWhileEnd) -import qualified Data.String as String +import Data.String qualified as String import Data.Typeable (typeOf) import GHC.Stack (SrcLoc(SrcLoc), srcLocEndCol, srcLocEndLine, srcLocFile, srcLocStartCol, srcLocStartLine) import Hedgehog.Internal.Exception (tryAll) -import Hedgehog.Internal.Property hiding (evalIO) +import Hedgehog.Internal.Property (Failure(..), MonadTest(..), mkTest) import Hedgehog.Internal.Source (ColumnNo(..), LineNo(..), Span(..)) import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) diff --git a/src/Test/Cleveland/Internal/Pure.hs b/src/Test/Cleveland/Internal/Pure.hs --- a/src/Test/Cleveland/Internal/Pure.hs +++ b/src/Test/Cleveland/Internal/Pure.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Integration with integrational testing engine (pun intended). module Test.Cleveland.Internal.Pure @@ -30,46 +29,48 @@ , psNow , psLevel , psGState - , psExecutorResult , psContractsNames ) where -import Control.Lens (assign, makeLenses, modifying, to, (%=), (.=)) +import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=)) import Control.Monad.Catch.Pure (CatchT, runCatchT) import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell) import Data.Constraint (Dict(..), withDict, (\\)) import Data.Default (def) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Monoid (Ap(..)) -import qualified Data.Set as Set +import Data.Set qualified as Set +import Data.Singletons (sing) import Data.Type.Equality (type (:~:)(Refl)) -import Fmt (Buildable(..), Builder, indentF, pretty, unlinesF, (+|), (|+)) +import Fmt (Buildable(..), Builder, build, pretty, unlinesF, (+|), (|+)) import Time (Second, toNum, toUnit) import Lorentz (Mutez, NiceComparable, pattern DefEpName) +import Lorentz qualified as L import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg) -import qualified Lorentz.Value as L (TAddress(..), ToTAddress(..)) -import Morley.Client (Alias, mkAlias) -import Morley.Client.RPC.AsRPC (notesAsRPC, rpcStorageScopeEvi, valueAsRPC) +import Morley.AsRPC + (HasRPCRepr(AsRPC), MaybeRPC(..), notesAsRPC, replaceBigMapIds, rpcStorageScopeEvi, valueAsRPC) +import Morley.Client (Alias, OperationInfo(..), mkAlias) import Morley.Client.TezosClient.Types (unsafeCoerceAliasHintToAlias, unsafeGetAliasHintText) import Morley.Michelson.Interpret (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer) -import qualified Morley.Michelson.Runtime as Runtime (ExecutorOp(..)) +import Morley.Michelson.Runtime qualified as Runtime (ExecutorOp(..)) import Morley.Michelson.Runtime.Dummy (dummyLevel, dummyMaxSteps, dummyNow, dummyOrigination) import Morley.Michelson.Runtime.GState - (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, + (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, gsCounterL, gsVotingPowersL, initGState) import Morley.Michelson.TypeCheck (TCError(..), typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), ToT, Value, Value'(..), castM, dfsFoldMapValue, fromVal, requireEq, toVal) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address, detGenKeyAddress) import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez) import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic) +import Morley.Util.MismatchError import Morley.Util.Named import Test.Cleveland.Internal.Abstract @@ -84,11 +85,10 @@ , _psNow :: Timestamp , _psLevel :: Natural , _psGState :: GState - , _psExecutorResult :: Maybe ExecutorRes - -- ^ Store the most recent result of interpreted operations. , _psContractsNames :: Map Address Text -- ^ Map from contracts addresses to human-readable names. } + deriving stock Show instance MonadState PureState PureM where get = ask >>= readIORef @@ -100,7 +100,7 @@ { unPureM :: ReaderT (IORef PureState) (CatchT (WriterT LogsInfo IO)) a } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, - MonadReader (IORef PureState), MonadWriter LogsInfo) + MonadReader (IORef PureState), MonadWriter LogsInfo, MonadFail) type Aliases = Map Alias AliasData @@ -110,12 +110,13 @@ { adAddress :: Address , adMbSecretKey :: Maybe SecretKey } + deriving stock Show data TestError = UnexpectedTypeCheckError TCError - | UnexpectedStorageType T.T T.T - | UnexpectedBigMapKeyType T.T T.T - | UnexpectedBigMapValueType T.T T.T + | UnexpectedStorageType (MismatchError T.T) + | UnexpectedBigMapKeyType (MismatchError T.T) + | UnexpectedBigMapValueType (MismatchError T.T) | CustomTestError Text deriving stock Show @@ -128,22 +129,12 @@ instance Buildable TestError where build (UnexpectedTypeCheckError tcErr) = "Unexpected type check error. Reason: " +| tcErr |+ "" - build (UnexpectedStorageType actualT expectedT) = unlinesF - [ "Expected storage to be of type:" - , indentF 2 $ build $ expectedT - , "But its type was:" - , indentF 2 $ build $ actualT - ] - build (UnexpectedBigMapKeyType actualT expectedT) = unlinesF - [ "Expected big_map's key type to be: " <> build expectedT - , "But its type was: " <> build actualT - ] - build (UnexpectedBigMapValueType actualT expectedT) = unlinesF - [ "Expected big_map's value type to be:" - , indentF 2 $ build expectedT - , "But its type was:" - , indentF 2 $ build actualT - ] + build (UnexpectedStorageType merr) = + "Unexpected storage type.\n" +| merr |+ "" + build (UnexpectedBigMapKeyType merr) = + "Unexpected big map key type.\n" +| merr |+ "" + build (UnexpectedBigMapValueType merr) = + "Unexpected big map value type.\n" +| merr |+ "" build (CustomTestError msg) = pretty msg instance Exception TestError where @@ -161,8 +152,7 @@ runEmulatedT moneybagAlias' scenario = runClevelandT moneybagAlias' do clevelandCaps <- ask - let emulatedCaps = EmulatedCaps emulatedImpl clevelandCaps - lift $ runReaderT scenario emulatedCaps + lift . runReaderT scenario $ EmulatedCaps emulatedImpl clevelandCaps runClevelandT :: Alias -> ClevelandT PureM a -> IO a runClevelandT moneybagAlias' scenario = do @@ -196,10 +186,10 @@ mapClevelandOpsImplExceptions (addCallStack . exceptionHandler) ClevelandOpsImpl { coiRunOperationBatch = mapM \case - OriginateOp UntypedOriginateData{..} -> do + OpOriginate UntypedOriginateData{..} -> do ref <- originate uodContract (pretty uodName) uodStorage uodBalance - OriginateResult <$> saveAlias uodName (toAddress ref) Nothing - TransferOp TransferData{..} -> do + OpOriginate <$> saveAlias uodName (toAddress ref) Nothing + OpTransfer TransferData{..} -> do let fromAddr = #from :! sender let toAddr = #to :! toAddress tdTo refillable <- isAddressRefillable sender @@ -217,7 +207,10 @@ transfer @() fromAddr toAddr tdAmount (TrustEpName tdEntrypoint) tdParameter - return TransferResult + return $ OpTransfer () + OpReveal{} -> do + -- We do not care about reveals in our Morley runtime + return $ OpReveal () } clevelandMiscImpl :: ClevelandMiscImpl PureM @@ -238,8 +231,8 @@ mbSk <- maybe (unknownAlias alias) (pure . adMbSecretKey) mbMbSk case mbSk of Nothing -> - throwM . CustomTestError . - mappend "Given address doesn't have known associated secret key: " . show $ alias + cmiFailure $ + "Given address doesn't have known associated secret key: " <> build alias Just sk -> liftIO $ sign sk bs , cmiGenKey = \alias -> do @@ -263,8 +256,8 @@ aliasInfo <- maybe (unknownAddress addr) pure mbAliasInfo case adMbSecretKey aliasInfo of Nothing -> - throwM . CustomTestError . - mappend "Given address doesn't have known associated public key: " . show $ addr + cmiFailure $ + "Given address doesn't have known associated public key: " <> build addr Just sk -> pure $ toPublic sk , cmiGetDelegate = \addr -> do ContractState _ _ _ delegate <- contractStorage addr @@ -282,14 +275,17 @@ , cmiGetNow = use psNow , cmiGetLevel = use psLevel , cmiGetApproximateBlockInterval = pure $ sec 1 - , cmiFailure = throwM . CustomTestError . pretty , cmiAttempt = try , cmiThrow = throwM , cmiMarkAddressRefillable = setAddressRefillable , cmiGetBalance = getBalance + , cmiEmulatedImpl = pure $ Just emulatedImpl , .. } where + cmiFailure :: forall a. Builder -> PureM a + cmiFailure = throwM . CustomTestError . pretty + setAddressRefillable addr = psRefillableAddresses %= Set.insert addr originateUntyped :: Sender -> UntypedOriginateData -> PureM Address @@ -303,31 +299,34 @@ => BigMapId k v -> k -> PureM (Maybe v) - cmiGetBigMapValueMaybe bmId k = do - mbBigMap <- findBigMapById bmId - case mbBigMap of - Nothing -> pure Nothing - Just bigMap -> pure $ fromVal @v <$> Map.lookup (toVal k) bigMap + cmiGetBigMapValueMaybe (BigMapId bmId) k = runMaybeT do + VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId + hoistMaybe $ fromVal @v <$> Map.lookup (toVal k) bigMap cmiGetAllBigMapValuesMaybe :: forall k v. (NiceComparable k, IsoValue v) => BigMapId k v -> PureM (Maybe [v]) - cmiGetAllBigMapValuesMaybe bmId = do - mbBigMap <- findBigMapById bmId - case mbBigMap of - Nothing -> pure Nothing - Just bigMap -> pure $ Just $ fromVal @v <$> Map.elems bigMap + cmiGetAllBigMapValuesMaybe (BigMapId bmId) = runMaybeT do + VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId + pure $ fromVal @v <$> Map.elems bigMap + findBigMapById + :: forall k v. (SingI v, SingI k) + => Natural -> PureM (Value ('T.TBigMap k v)) + findBigMapById bigMapId = + runMaybeT (findBigMapByIdMaybe @k @v bigMapId) >>= maybe notFound pure + where + notFound = cmiFailure $ "BigMap with ID " <> build bigMapId <> " not found." + + -- | Traverse storage values of all contracts and looks for a big_map with the given ID. -- If multiple big_maps with the given ID are found, it fails with error. - findBigMapById - :: forall k v. - (NiceComparable k, IsoValue v) - => BigMapId k v - -> PureM (Maybe (Map (Value (ToT k)) (Value (ToT v)))) - findBigMapById (BigMapId bigMapId) = do + findBigMapByIdMaybe + :: forall k v. (SingI v, SingI k) + => Natural -> MaybeT PureM (Value ('T.TBigMap k v)) + findBigMapByIdMaybe bigMapId = MaybeT do addresses <- use $ psGState . gsAddressesL . to Map.elems let Ap result = @@ -353,15 +352,15 @@ -- If multiple big_maps with the given ID are found, they'll all be returned. findBigMapInStorage :: forall k v st. (SingI k, SingI v) - => Value st -> Natural -> Ap (Either TestError) [Map (Value k) (Value v)] + => Value st -> Natural -> Ap (Either TestError) [Value ('T.TBigMap k v)] findBigMapInStorage storage bigMapId = dfsFoldMapValue - (\case - VBigMap (Just bigMapId') (bigMap :: Map (Value k') (Value v')) + (\v -> case v of + VBigMap (Just bigMapId') (_ :: Map (Value k') (Value v')) | bigMapId == bigMapId' -> do Refl <- requireEq @k' @k (Ap . Left ... UnexpectedBigMapKeyType) Refl <- requireEq @v' @v (Ap . Left ... UnexpectedBigMapValueType) - pure [bigMap] + pure [v] _ -> Ap $ Right [] ) storage @@ -409,6 +408,57 @@ psDefaultAliasesCounter %= \(DefaultAliasCounter i) -> DefaultAliasCounter $ i + 1 return $ mkDefaultAlias counter + cmiRunCode + :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st)) + => Sender -> RunCode cp st vd -> PureM (AsRPC st) + cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcBalance rcSource) = do + -- Pattern match on the contract constructor to reveal + -- a proof of `NiceParameter cp` and `NiceStorage st` + L.Contract{} <- pure rcContract + param <- maybeRPCToVal rcParameter + storage <- maybeRPCToVal rcStorage + + res <- interpret do + counter0 <- use $ esGState . gsCounterL + contractAddr <- + executeOrigination ! #isGlobalOp True $ + (dummyOrigination storage (L.toMichelsonContract rcContract) counter0) { ooBalance = zeroMutez } + \\ L.niceStorageEvi @st + \\ L.niceParameterEvi @cp + + esSourceAddress .= rcSource + counter1 <- use $ esGState . gsCounterL + let overrideContractBalance = Just rcBalance + executeTransfer (#isGlobalOp :! False) overrideContractBalance def $ + TransferOperation + { toDestination = contractAddr + , toCounter = counter1 + , toTxData = TxData + { tdSenderAddress = sender + , tdParameter = TxTypedParam param \\ L.niceParameterEvi @cp + , tdEntrypoint = DefEpName + , tdAmount = rcAmount + } + } + pure contractAddr + case res of + Left executorError -> throwEE executorError + Right (executorRes, contractAddr) -> do + -- Find the storage of the contract and return it in its RPC representation. + case executorRes ^. erGState . gsAddressesL . at contractAddr of + Nothing -> + cmiFailure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'" + Just (ASSimple {}) -> + cmiFailure $ "Internal error: expected address to belong to a contract: '" +| contractAddr |+ "'" + Just (ASContract (ContractState _ _ (finalStorage :: Value actualSt) _)) -> do + finalStorage' <- castM @actualSt @(ToT st) finalStorage (throwM . UnexpectedStorageType) + pure $ fromVal $ valueAsRPC finalStorage' + where + maybeRPCToVal :: MaybeRPC v -> PureM (Value (ToT v)) + maybeRPCToVal = \case + NotRPC v -> pure $ toVal v + IsRPC v -> replaceBigMapIds findBigMapById sing $ toVal v + isAddressRefillable :: Address -> PureM Bool isAddressRefillable addr = Set.member addr <$> use psRefillableAddresses @@ -431,7 +481,7 @@ exceptionToTransferFailure err = case err of EEZeroTransaction addr -> return $ TransferFailure (addrNameToAddr addr) EmptyTransaction EEIllTypedParameter addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter - EEUnexpectedParameterType addr _ _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter + EEUnexpectedParameterType addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) -> case mfwsFailed of MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsInstrCallStack) @@ -451,7 +501,7 @@ getStorageImpl addr = do withDict (pickNiceStorage @st addr) $ do ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toAddress addr) - val <- castM @actualT @(ToT st) storage (throwM ... UnexpectedStorageType) + val <- castM @actualT @(ToT st) storage (throwM . UnexpectedStorageType) pure $ T.fromVal val -- Attempt to retrieve a ContractState given for the given address. Fails if the @@ -463,7 +513,7 @@ case Map.lookup addr gsAddresses of Just (ASContract contractState) -> pure contractState Just (ASSimple {}) -> throwM . CustomTestError $ - "Expected address to be contract with storage, but it's a simple address: " <> show addr + "Expected address to be contract with storage, but it's a simple address: " <> pretty addr Nothing -> unknownAddress addr resolve :: Alias -> PureM Address @@ -510,7 +560,6 @@ , _psNow = dummyNow , _psLevel = dummyLevel , _psGState = initGState - , _psExecutorResult = Nothing , _psContractsNames = Map.empty } @@ -534,20 +583,22 @@ -> epRef -> epArg -> PureM () -transfer (N from) (N toAddr) money epRef param = +transfer (arg #from -> from) (arg #to -> toAddr) money epRef param = let L.TAddress to' = L.toTAddress @cp @vd toAddr in case useHasEntrypointArg @cp @epRef @epArg epRef of - (Dict, epName) -> registerInterpretation . one . Runtime.TransferOp $ TransferOperation - { toDestination = to' - , toCounter = 0 - , toTxData = TxData - { tdSenderAddress = from - , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $ - TxTypedParam (T.toVal param) - , tdEntrypoint = epName - , tdAmount = money + (Dict, epName) -> registerInterpretation do + executeGlobalOperations def $ one $ + Runtime.TransferOp $ TransferOperation + { toDestination = to' + , toCounter = 0 + , toTxData = TxData + { tdSenderAddress = from + , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $ + TxTypedParam (T.toVal param) + , tdEntrypoint = epName + , tdAmount = money + } } - } -- | Originate a contract with given initial storage and balance. Its -- address is returned. @@ -557,10 +608,8 @@ Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr Right (T.SomeContractAndStorage contract storage) -> do counter <- gsCounter <$> use psGState - result <- interpret . executeGlobalOrigination $ + address <- registerInterpretation . executeGlobalOrigination $ (dummyOrigination storage contract counter) { ooBalance = balance } - putResult $ fmap fst result - address <- either throwEE (pure . snd) $ result psContractsNames %= Map.insert address contractName return address @@ -570,34 +619,33 @@ st <- get throwM $ flip addrToAddrName st <$> err --- | Put an interpreted result to InternalState. -putResult :: Either ExecutorError ExecutorRes -> PureM () -putResult resOrErr = do - let - logs = case resOrErr of +-- | Runs a set of operations and updates the engine's state. +registerInterpretation :: ExecutorM a -> PureM a +registerInterpretation action = do + interpretedResult <- interpret action + tell $ extractLogs interpretedResult + + case interpretedResult of + Right (executorRes, res) -> do + psGState .= _erGState executorRes + pure res + Left executorError -> throwEE executorError + + where + extractLogs :: Either ExecutorError (ExecutorRes, a) -> [ScenarioLogs] + extractLogs = \case Left (EEInterpreterFailed addr (InterpretError e)) -> [ScenarioLogs addr $ snd e] - Right res -> res ^. erInterpretResults <&> \(addr, InterpretResult{..}) -> + Right (res, _) -> res ^. erInterpretResults <&> \(addr, InterpretResult{..}) -> ScenarioLogs addr iurMorleyLogs _ -> [] - tell logs - case resOrErr of - Right res -> psExecutorResult .= Just res - Left err -> throwEE err --- | Helper function which provides the results of the given operations. +-- | Interpret an action and return the result _without_ updating the engine's state. interpret :: ExecutorM a -> PureM (Either ExecutorError (ExecutorRes, a)) interpret action = do now <- use psNow level <- use psLevel gState <- use psGState - let interpretedResult = runExecutorM now level dummyMaxSteps gState action - whenRight interpretedResult $ \(result, _) -> psGState .= _erGState result - return interpretedResult - --- | Interprets provided list of operations. -registerInterpretation :: [Runtime.ExecutorOp] -> PureM () -registerInterpretation ops = - interpret (executeGlobalOperations def ops) <&> fmap fst >>= putResult + pure $ runExecutorM now level dummyMaxSteps gState action addrToAddrName :: Address -> PureState -> AddressName addrToAddrName addr iState = diff --git a/src/Test/Cleveland/Internal/Scenario.hs b/src/Test/Cleveland/Internal/Scenario.hs --- a/src/Test/Cleveland/Internal/Scenario.hs +++ b/src/Test/Cleveland/Internal/Scenario.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Cleveland.Internal.Scenario ( Scenario(..) @@ -10,7 +9,7 @@ , withInitialLevel ) where -import qualified Morley.Tezos.Core as TC +import Morley.Tezos.Core qualified as TC import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Pure diff --git a/src/Test/Cleveland/Lorentz.hs b/src/Test/Cleveland/Lorentz.hs --- a/src/Test/Cleveland/Lorentz.hs +++ b/src/Test/Cleveland/Lorentz.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-deprecations #-} @@ -72,5 +71,5 @@ import Test.Cleveland.Michelson.Dummy import Test.Cleveland.Michelson.Import (specWithContract, specWithTypedContract, specWithUntypedContract) -import qualified Test.Cleveland.Michelson.Unit as Michelson +import Test.Cleveland.Michelson.Unit qualified as Michelson import Test.Cleveland.Util diff --git a/src/Test/Cleveland/Lorentz/Consumer.hs b/src/Test/Cleveland/Lorentz/Consumer.hs --- a/src/Test/Cleveland/Lorentz/Consumer.hs +++ b/src/Test/Cleveland/Lorentz/Consumer.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Contract which remembers all parameters it has been called with. -- @@ -15,6 +14,6 @@ import Lorentz.Run -- | Remembers parameters it was called with, last goes first. -contractConsumer :: (NiceParameterFull cp, NiceStorage cp) => Contract cp [cp] () +contractConsumer :: (NiceParameterFull cp, NiceStorageFull cp) => Contract cp [cp] () contractConsumer = defaultContract $ unpair # cons # nil # pair diff --git a/src/Test/Cleveland/Lorentz/Entrypoints.hs b/src/Test/Cleveland/Lorentz/Entrypoints.hs --- a/src/Test/Cleveland/Lorentz/Entrypoints.hs +++ b/src/Test/Cleveland/Lorentz/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Utility functions for checking predicates on contract's entrypoints for -- Lorentz @@ -16,6 +15,7 @@ import Test.Tasty (TestName) +import Lorentz (NiceParameterFull) import Test.Cleveland.Lorentz.Internal.Entrypoints import Test.Cleveland.Michelson.Internal.Entrypoints (ignoreExtraEntrypoints) @@ -31,6 +31,6 @@ -- 'Map' of names to types. Checks both the contract type and the contract itself (when represented as -- an untyped Michelson contract). testContractCoversEntrypoints, - testContractMatchesEntrypoints :: TestName -> ContractEPTest contractEps st vd + testContractMatchesEntrypoints :: NiceParameterFull contractEps => TestName -> ContractEPTest contractEps st vd testContractCoversEntrypoints = testCompareContractEntrypoints ignoreExtraEntrypoints testContractMatchesEntrypoints = testCompareContractEntrypoints id diff --git a/src/Test/Cleveland/Lorentz/Import.hs b/src/Test/Cleveland/Lorentz/Import.hs --- a/src/Test/Cleveland/Lorentz/Import.hs +++ b/src/Test/Cleveland/Lorentz/Import.hs @@ -1,11 +1,14 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Functions to import contracts to be used in tests. module Test.Cleveland.Lorentz.Import ( -- * Read, parse, typecheck contracts importContract + , importContractExt , embedContract , embedContractM , M.ContractReadError (..) @@ -21,20 +24,21 @@ ) where import Fmt (build, pretty) -import qualified Language.Haskell.TH as TH +import Language.Haskell.TH qualified as TH -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Base import Lorentz.Constraints import Lorentz.ViewBase import Morley.Michelson.Parser.Types (MichelsonSource(..)) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Runtime.Import qualified as MR +import Morley.Michelson.Typed qualified as T import Morley.Util.Markdown -import qualified Test.Cleveland.Michelson.Import as M +import Test.Cleveland.Michelson.Import qualified as M mkImportedContract :: forall cp st vd. - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) => FilePath -> T.Contract (T.ToT cp) (T.ToT st) -> Either L.ViewInterfaceMatchError (Contract cp st vd) @@ -58,11 +62,26 @@ -- always works as views descriptor of the contract. importContract :: forall cp st vd. - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) => FilePath -> IO (Contract cp st vd) importContract file = either throwM pure . mkImportedContract file =<< M.importContract file +-- | Import contract from a given 'FilePath', with deprecated Morley extensions. +-- +-- In this and similar functions, parameter and storage types must exactly match +-- the ones in the contract, while for views this is not necessary. Only +-- make sure that all views beyond @vd@ type are present in the contract; @()@ +-- always works as views descriptor of the contract. +importContractExt + :: forall cp st vd. + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) + => FilePath -> IO (Contract cp st vd) +importContractExt file = + either throwM pure . mkImportedContract file =<< MR.importUsing MR.readContractExt file + +{-# DEPRECATED importContractExt "Morley extensions are deprecated" #-} + {- | Import a contract at compile time assuming its expected type is known. Use it like: @@ -78,7 +97,7 @@ -} embedContract :: forall cp st vd. - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) => FilePath -> TH.TExpQ (Contract cp st vd) embedContract path = embedContractM (pure path) @@ -90,7 +109,7 @@ -- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends" embedContractM :: forall cp st vd. - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) => IO FilePath -> TH.TExpQ (Contract cp st vd) embedContractM pathM = do path <- TH.runIO pathM @@ -105,13 +124,13 @@ fail (pretty e) -- Emit a haskell expression that reads the contract. Right _ -> [|| - -- Note: it's ok to use `error` here, because we just proved that the contract + -- Note: it's ok to use `unsafe` here, because we just proved that the contract -- can be parsed+typechecked. contract & M.readContract (MSFile path) - & either (error . pretty) id + & unsafe & mkImportedContract path - & either (error . pretty) id + & unsafe ||] -- | Import a value from a given 'FilePath' diff --git a/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs b/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs --- a/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs +++ b/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Internal utilities for unit testing. @@ -22,13 +21,15 @@ import Test.Tasty.HUnit (testCase) import Morley.Michelson.Typed (convertContract, flattenEntrypoints) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U +import Morley.Util.Named -import qualified Test.Cleveland.Michelson.Internal.Entrypoints as M +import Test.Cleveland.Michelson.Internal.Entrypoints qualified as M -- | Utility type synonym type ContractEPTypeTest expectedEps - = forall contractEps st vd. NiceParameterFull expectedEps + = forall contractEps st vd. + (NiceParameterFull expectedEps, NiceParameterFull contractEps) => Contract contractEps st vd -> TestTree -- | Utility type synonym @@ -58,7 +59,8 @@ -- @id@ for match test. testCompareContractEntrypoints :: forall contractEps st vd. - (M.EPMismatch -> M.EPMismatch) + NiceParameterFull contractEps + => (M.EPMismatch -> M.EPMismatch) -> TestName -> ContractEPTest contractEps st vd testCompareContractEntrypoints compareMode name contract@Contract{} spec = withDict (niceParameterEvi @contractEps) $ @@ -68,7 +70,7 @@ in testGroup name [ testCase "Contract type matches entrypoint spec" $ M.assertEPComparisonSuccessful . Right . compareMode $ - M.compareEntrypoints (M.EPExpected spec) (M.EPActual entrypointsInType) + M.compareEntrypoints (#expected :! spec) (#actual :! entrypointsInType) , M.testContractEntrypoints compareMode "Untyped contract matches entrypoint spec" contract' spec ] diff --git a/src/Test/Cleveland/Lorentz/Requester.hs b/src/Test/Cleveland/Lorentz/Requester.hs --- a/src/Test/Cleveland/Lorentz/Requester.hs +++ b/src/Test/Cleveland/Lorentz/Requester.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -28,7 +27,7 @@ contractRequester :: forall name arg ret vd cp st. ( NiceParameterFull cp, NiceStorage cp - , NiceParameterFull arg, NiceStorage [ret] + , NiceParameterFull arg, NiceStorageFull [ret] , NiceViewable arg, NiceViewable ret, HasView vd name arg ret , Typeable vd, KnownSymbol name ) diff --git a/src/Test/Cleveland/Lorentz/Ticketer.hs b/src/Test/Cleveland/Lorentz/Ticketer.hs --- a/src/Test/Cleveland/Lorentz/Ticketer.hs +++ b/src/Test/Cleveland/Lorentz/Ticketer.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Contract that facilitates tickets emission. module Test.Cleveland.Lorentz.Ticketer diff --git a/src/Test/Cleveland/Lorentz/Types.hs b/src/Test/Cleveland/Lorentz/Types.hs --- a/src/Test/Cleveland/Lorentz/Types.hs +++ b/src/Test/Cleveland/Lorentz/Types.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Basic types for the test framework. module Test.Cleveland.Lorentz.Types @@ -28,7 +27,7 @@ import Lorentz.Address import Lorentz.Constraints -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T -- | Handle to a contract. -- @@ -39,7 +38,7 @@ -- world, so it has no 'T.IsoValue' and related instances and cannot be used in -- Lorentz code. data ContractHandle (cp :: Type) (st :: Type) (vd :: Type) = - (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) => + (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) => ContractHandle { chContractName :: Text , chAddress :: Address diff --git a/src/Test/Cleveland/Michelson.hs b/src/Test/Cleveland/Michelson.hs --- a/src/Test/Cleveland/Michelson.hs +++ b/src/Test/Cleveland/Michelson.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-deprecations #-} diff --git a/src/Test/Cleveland/Michelson/Dummy.hs b/src/Test/Cleveland/Michelson/Dummy.hs --- a/src/Test/Cleveland/Michelson/Dummy.hs +++ b/src/Test/Cleveland/Michelson/Dummy.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Dummy data to be used in tests where it's not essential. diff --git a/src/Test/Cleveland/Michelson/Entrypoints.hs b/src/Test/Cleveland/Michelson/Entrypoints.hs --- a/src/Test/Cleveland/Michelson/Entrypoints.hs +++ b/src/Test/Cleveland/Michelson/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2022 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Utility functions for checking predicates on contract's entrypoints. @@ -15,7 +14,7 @@ import Test.Tasty (TestName, TestTree) import Morley.Michelson.Untyped hiding (Contract) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Test.Cleveland.Michelson.Internal.Entrypoints diff --git a/src/Test/Cleveland/Michelson/Import.hs b/src/Test/Cleveland/Michelson/Import.hs --- a/src/Test/Cleveland/Michelson/Import.hs +++ b/src/Test/Cleveland/Michelson/Import.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | Functions to import contracts to be used in tests. module Test.Cleveland.Michelson.Import @@ -28,6 +30,8 @@ , testTreesWithContract , testTreesWithTypedContract , testTreesWithUntypedContract + , testTreesWithUntypedContractExt + , testTreesWithTypedContractExt , concatTestTrees -- * HSpec helpers @@ -41,9 +45,9 @@ import Control.Exception (IOException) import Data.FileEmbed (makeRelativeToProject) -import qualified Data.Text.IO.Utf8 as Utf8 (readFile) +import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Fmt (pretty) -import qualified Language.Haskell.TH as TH +import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Syntax (qAddDependentFile) import Test.HUnit (assertFailure) import Test.Hspec (Spec, describe, expectationFailure, it, runIO) @@ -52,7 +56,7 @@ import Morley.Michelson.Runtime.Import import Morley.Michelson.Typed (Contract, SingI) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U {-# DEPRECATED specWithContract @@ -62,6 +66,13 @@ "Use testTreesWithContract &c. instead" #-} +{-# DEPRECATED + testTreesWithUntypedContractExt + , testTreesWithTypedContractExt + + "Morley extensions are deprecated" + #-} + ---------------------------------------------------------------------------- -- tasty helpers ---------------------------------------------------------------------------- @@ -84,6 +95,14 @@ testTreesWithUntypedContract = testTreesWithContractImpl importUntypedContract +-- | Like 'testTreesWithContract' but supplies only untyped contract +-- with Morley extensions (deprecated). +testTreesWithUntypedContractExt + :: HasCallStack + => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree] +testTreesWithUntypedContractExt = + testTreesWithContractImpl (importUsing readUntypedContractExt) + -- | Like 'testTreesWithContract' but supplies only typed contract. testTreesWithTypedContract :: (Each '[SingI] [cp, st], HasCallStack) @@ -91,6 +110,14 @@ testTreesWithTypedContract = testTreesWithContractImpl importContract +-- | Like 'testTreesWithContract' but supplies only typed contract +-- with Morley extensions (deprecated). +testTreesWithTypedContractExt + :: (Each '[SingI] [cp, st], HasCallStack) + => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree] +testTreesWithTypedContractExt = + testTreesWithContractImpl (importUsing readContractExt) + testTreesWithContractImpl :: HasCallStack => (FilePath -> IO contract) @@ -201,8 +228,8 @@ Right _ -> -- Emit a haskell expression that reads the contract. [|| - -- Note: it's ok to use `error` here, because we just proved that the contract + -- Note: it's ok to use `unsafe` here, because we just proved that the contrPact -- can be parsed+typechecked. - either (error . pretty) id $ + unsafe $ readContract (MSFile path) contract ||] diff --git a/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs b/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs --- a/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs +++ b/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs @@ -1,13 +1,10 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Internal utilities for unit testing. module Test.Cleveland.Michelson.Internal.Entrypoints ( EPList - , EPExpected(..) - , EPActual(..) , EPMismatch(.., EPComparisonResultOK) , ignoreExtraEntrypoints , compareEntrypoints @@ -20,8 +17,8 @@ ) where import Data.Aeson (eitherDecode, encode) -import qualified Data.Map as Map -import Fmt (Buildable(..), blockMapF, indentF, nameF, pretty, unlinesF, (+|), (|+)) +import Data.Map qualified as Map +import Fmt (Buildable(..), blockMapF, nameF, pretty, unlinesF) import Test.HUnit (Assertion, assertFailure) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (testCase) @@ -32,19 +29,13 @@ import Morley.Michelson.Runtime (parseExpandContract) import Morley.Michelson.TypeCheck (TCError, mkSomeParamType) import Morley.Michelson.Untyped hiding (Contract) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U +import Morley.Util.MismatchError (MismatchError(..)) +import Morley.Util.Named -- | Convenience type synonym for a list of pairs of entrypoint names and types type EPList = [(EpName, U.Ty)] --- | Newtype wrapper for the expected value in entrypoint comparison -newtype EPExpected a = EPExpected a - deriving stock (Eq, Show) - --- | Newtype wrapper for the actual value in entrypoint comparison -newtype EPActual a = EPActual a - deriving stock (Eq, Show) - -- | A pattern syononym for no mismatches pattern EPComparisonResultOK :: EPMismatch pattern EPComparisonResultOK <- EPMismatch [] [] [] @@ -57,14 +48,14 @@ , epmmMissing :: EPList -- ^ Missing entrypoints, i.e. those that exist in the specification, but not the -- actual contract - , epmmTypeMismatch :: [(EpName, (EPExpected U.Ty, EPActual U.Ty))] + , epmmTypeMismatch :: [(EpName, MismatchError Ty)] -- ^ Entrypoints that exist in both the contract and the specification, but types do not -- match. - } deriving stock (Eq, Show) + } instance Buildable EPMismatch where build EPComparisonResultOK = "Entrypoints match specificaton" - build EPMismatch{..} = nameF "Entrypoints do not match specification" $ indentF 2 $ + build EPMismatch{..} = nameF "Entrypoints do not match specification" $ unlinesF $ filter (/=mempty) [extra, missing, typemm] where extra | null epmmExtra = mempty @@ -74,34 +65,28 @@ typemm | null epmmTypeMismatch = mempty | otherwise = nameF "Type mismatch in entrypoints" $ blockMapF epmmTypeMismatch -instance Buildable (EPExpected Ty, EPActual Ty) where - build (expected, actual) = "" +| expected |+ ", " +| actual |+ "" - -instance Buildable a => Buildable (EPExpected a) where - build (EPExpected x) = nameF "Expected" $ build x - -instance Buildable a => Buildable (EPActual a) where - build (EPActual x) = nameF "Actual" $ build x - -- | Ignore extraneous entrypoint names in 'EPMismatch'. Essentially sets -- 'epmmExtra' to @[]@. ignoreExtraEntrypoints :: EPMismatch -> EPMismatch ignoreExtraEntrypoints mm = mm{ epmmExtra = [] } -- | Compare two sets of entrypoints. Accepts ordered 'Map's to enforce sorting order. -compareEntrypoints :: EPExpected (Map EpName U.Ty) -> EPActual (Map EpName U.Ty) -> EPMismatch -compareEntrypoints (EPExpected expected) (EPActual actual) = EPMismatch{..} +compareEntrypoints :: "expected" :! Map EpName U.Ty -> "actual" :! (Map EpName U.Ty) -> EPMismatch +compareEntrypoints (arg #expected -> expected) (arg #actual -> actual) = EPMismatch{..} where epmmExtra = Map.toList $ Map.difference actual expected epmmMissing = Map.toList $ Map.difference expected actual inBoth = Map.intersectionWith (,) expected actual - epmmTypeMismatch = Map.toList $ Map.map (bimap EPExpected EPActual) $ Map.filter (uncurry (/=)) inBoth + epmmTypeMismatch = Map.toList $ flip Map.mapMaybe inBoth \(e, a) -> + if e /= a + then Just $ MkMismatchError { meExpected = e, meActual = a } + else Nothing -- | Check if the contract exactly matches the given entrypoints. Will report both -- missing and extraneous entrypoint names, and type mismatches. contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TCError EPMismatch contractMatchesEntrypoints (contractParameter -> pt) expected = case mkSomeParamType pt of - Right{} -> Right $ compareEntrypoints (EPExpected expected) (EPActual $ mkEntrypointsMap pt) + Right{} -> Right $ compareEntrypoints (#expected :! expected) (#actual :! mkEntrypointsMap pt) Left err -> Left err -- | Check if the contract contains the entrypoints given in spec (with matching types). @@ -142,7 +127,7 @@ -- and output, but bugs happen) michelsonRoundtripContract :: HasCallStack => U.Contract -> U.Contract michelsonRoundtripContract contract = - either (error . pretty) id . parseExpandContract MSUnspecified . toText + unsafe . parseExpandContract MSUnspecified . toText $ printUntypedContract True contract -- | Round-trip the contract through Micheline JSON representation. @@ -152,7 +137,7 @@ -- and output, but bugs happen) michelineRoundtripContract :: HasCallStack => U.Contract -> U.Contract michelineRoundtripContract contract = - either (error . pretty) id . fromExpression + unsafe . fromExpression . either (error . toText) id . eitherDecode . encode $ toExpression contract diff --git a/src/Test/Cleveland/Michelson/Unit.hs b/src/Test/Cleveland/Michelson/Unit.hs --- a/src/Test/Cleveland/Michelson/Unit.hs +++ b/src/Test/Cleveland/Michelson/Unit.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-deprecations #-} @@ -28,7 +27,7 @@ import Morley.Michelson.Interpret (ContractEnv, ContractReturn, MichelsonFailed(..), MichelsonFailureWithStack(..), interpret) import Morley.Michelson.Typed (Contract, IsoValue(..), ToT) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Test.Cleveland.Michelson.Dummy (dummyBigMapCounter, dummyGlobalCounter) import Test.Cleveland.Michelson.Internal.Entrypoints diff --git a/src/Test/Cleveland/Tasty.hs b/src/Test/Cleveland/Tasty.hs --- a/src/Test/Cleveland/Tasty.hs +++ b/src/Test/Cleveland/Tasty.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module allows the use of "Test.Cleveland" tests in @tasty@. -- diff --git a/src/Test/Cleveland/Tasty/Internal.hs b/src/Test/Cleveland/Tasty/Internal.hs --- a/src/Test/Cleveland/Tasty/Internal.hs +++ b/src/Test/Cleveland/Tasty/Internal.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE InstanceSigs #-} -- | This module is the internal implementation of "Test.Cleveland.Tasty". @@ -37,11 +36,11 @@ ) where import Control.Concurrent (modifyMVar, withMVar) -import qualified Data.Char as C +import Data.Char qualified as C import Data.Tagged (Tagged(Tagged)) import Fmt (pretty) import System.Environment (lookupEnv) -import qualified System.IO.Unsafe as Unsafe +import System.IO.Unsafe qualified as Unsafe import Test.Tasty (TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients, includingOptions, localOption, testGroup) @@ -80,7 +79,7 @@ -- -- If a 'TestTree' contains many tests scheduled to run on a real Tezos network, -- those tests will be run sequentially. -testScenario :: TestName -> (forall m. Monad m => Scenario m) -> TestTree +testScenario :: TestName -> (forall m. MonadFail m => Scenario m) -> TestTree testScenario testName scenario' = testGroup testName [ singleTest "On emulator" (RunOnEmulator scenario') diff --git a/src/Test/Cleveland/Tasty/Internal/Options.hs b/src/Test/Cleveland/Tasty/Internal/Options.hs --- a/src/Test/Cleveland/Tasty/Internal/Options.hs +++ b/src/Test/Cleveland/Tasty/Internal/Options.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module declares all options/flags that @tasty@ will -- parse from the command line/environment variables. @@ -21,14 +20,14 @@ import Control.Monad.Except (runExcept) import Data.Tagged (untag) -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import Options.Applicative.Types (Parser, ReadM(..)) import Servant.Client.Core (BaseUrl(..)) import Test.Tasty.Options as Tasty (IsOption(..), OptionDescription(Option), safeRead) import Morley.Client (Alias, mkAlias) import Morley.Client.Parser (baseUrlReader) -import qualified Morley.Tezos.Crypto as Crypto +import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.CLI (HasCLReader(getMetavar, getReader)) -- $defaultValues diff --git a/src/Test/Cleveland/Tasty/Internal/Report.hs b/src/Test/Cleveland/Tasty/Internal/Report.hs --- a/src/Test/Cleveland/Tasty/Internal/Report.hs +++ b/src/Test/Cleveland/Tasty/Internal/Report.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Pretty-printers for reports in Tasty logs. module Test.Cleveland.Tasty.Internal.Report @@ -9,14 +8,14 @@ import Data.Char (isPrint, isSpace) import Data.Ix (Ix(inRange)) -import qualified Data.List as List -import qualified Data.Text.IO.Utf8 as Utf8 +import Data.List qualified as List +import Data.Text.IO.Utf8 qualified as Utf8 import Fmt (Buildable(build), Builder, indentF, padLeftF, unlinesF, (+|), (|+)) import GHC.Stack (SrcLoc(..)) import System.Directory (makeRelativeToCurrentDirectory) import System.IO.Error (IOError, catchIOError, ioError, isAlreadyInUseError, isDoesNotExistError, isPermissionError) -import qualified Unsafe +import Unsafe qualified -- HLint wrongfully thinks we are not using these things from universum, -- perhaps because of morley-prelude. diff --git a/src/Test/Cleveland/Util.hs b/src/Test/Cleveland/Util.hs --- a/src/Test/Cleveland/Util.hs +++ b/src/Test/Cleveland/Util.hs @@ -1,13 +1,13 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# LANGUAGE QuantifiedConstraints #-} + -- | Testing utility functions used by testing framework itself or -- intended to be used by test writers. module Test.Cleveland.Util ( leftToShowPanic - , leftToPrettyPanic , (?-) -- * Property @@ -27,7 +27,6 @@ , roundtripTree , assertGoesBefore , goesBefore - , partialParse -- * Pretty-printing , formatValue @@ -43,7 +42,7 @@ -- * Bytes , stripOptional0x , fromHex - , unsafeFromHex + , parseAddressFromHex -- * Traversals , mapEach @@ -56,7 +55,9 @@ , mcs, ms, sec, minute ) where -import Control.Lens as L +import Debug qualified (show) + +import Control.Lens qualified as L import Control.Monad.Random (MonadRandom, evalRand, mkStdGen) import Criterion (Benchmarkable, benchmarkWith', nf, whnf) import Criterion.Main (defaultConfig) @@ -64,21 +65,18 @@ import Data.Fixed (Fixed, HasResolution) import Data.Ratio ((%)) import Data.Singletons (demote) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time (NominalDiffTime, secondsToNominalDiffTime) import Data.Typeable (typeRep) -import Fmt (Buildable, Builder, build, pretty, (+|), (+||), (|+), (||+)) +import Fmt (Buildable, Builder, build, pretty, (+|), (|+)) import Hedgehog (Gen, MonadGen, MonadTest, Property, annotate, evalIO, failure, forAll, property, success, tripping, withTests) -import qualified Hedgehog.Gen as Gen +import Hedgehog.Gen qualified as Gen import Hedgehog.Internal.Gen (runGenT) -import qualified Hedgehog.Internal.Seed as Seed +import Hedgehog.Internal.Seed qualified as Seed import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue) -import qualified Hedgehog.Range as Range -import Morley.Michelson.Doc (DocItem, docItemPosition) -import Morley.Michelson.Typed (OpPresence(OpAbsent, OpPresent), SingI, SomeValue(..), sing) -import qualified Morley.Michelson.Typed as T +import Hedgehog.Range qualified as Range import Statistics.Types (Estimate(estPoint)) import Test.HUnit (Assertion, assertFailure) import Test.Tasty (TestTree) @@ -86,11 +84,18 @@ import Test.Tasty.Hedgehog (testProperty) import Text.Hex (decodeHex) import Text.Printf (printf) -import qualified Text.Show +import Text.Show qualified import Time (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, Rat, RatioNat, Second, Time, mcs, minute, ms, ns, sec, time, timeout, toUnit, unTime, unitNameVal) +import Morley.Michelson.Doc (DocItem, docItemPosition) +import Morley.Michelson.Typed (SingI, SomeConstrainedValue(..)) +import Morley.Michelson.Typed qualified as T +import Morley.Tezos.Address (Address, parseAddressRaw) + +import Test.Cleveland.Instances () + {- Note [Hedgehog & withFrozenCallStack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -111,12 +116,9 @@ See: Note [Cleveland & callstacks] for more information. -} -leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a +leftToShowPanic :: (PrettyShow e, Show e, HasCallStack) => Either e a -> a leftToShowPanic = either (error . show) id -leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a -leftToPrettyPanic = either (error . pretty) id - -- | Make a tuple with name without extra syntactic noise. (?-) :: Text -> a -> (Text, a) (?-) = (,) @@ -142,7 +144,7 @@ Left _ -> succeededTest Right x -> -- See: Note [Hedgehog & withFrozenCallStack] - withFrozenCallStack $ failedTest $ "expected Left, got Right (" <> show x <> ")" + withFrozenCallStack $ failedTest $ "expected Left, got Right (" <> Debug.show x <> ")" -- | The 'Property' holds on `Right b`. eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m () @@ -150,7 +152,7 @@ Right _ -> succeededTest Left x -> -- See: Note [Hedgehog & withFrozenCallStack] - withFrozenCallStack $ failedTest $ "expected Right, got Left (" <> show x <> ")" + withFrozenCallStack $ failedTest $ "expected Right, got Left (" <> Debug.show x <> ")" -- | Benchmarks the given function and checks that the mean time to evaluate to weak head -- normal form is under the given amount of time. @@ -233,7 +235,7 @@ node = fromMaybe discardedErr $ runIdentity $ runMaybeT $ runTreeT tree discardedErr = error $ "Generator could not produce a value for size " - <> show size <> " and seed " <> show seed + <> show (Range.unSize size) <> " and seed " <> show seed in nodeValue node ---------------------------------------------------------------------------- @@ -288,24 +290,18 @@ => Proxy d1 -> Proxy d2 -> TestTree goesBefore dp1 dp2 = testCase testName (assertGoesBefore dp1 dp2) where - testName = "`" +|| typeRep dp1 ||+ "` should come before `" +|| typeRep dp2 ||+ "`" - --- | Helper function for running parser in test environment -partialParse :: (HasCallStack, Buildable b) => (a -> Either b c) -> a -> c -partialParse f = either (error . pretty) id . f + testName = "`" +| show @Text (typeRep dp1) |+ "` should come before `" + +| show @Text (typeRep dp2) |+ "`" ---------------------------------------------------------------------------- -- Pretty-printing ---------------------------------------------------------------------------- formatValue :: forall t. SingI t => T.Value t -> Builder -formatValue v = - case T.checkOpPresence (sing @t) of - OpPresent -> show v - OpAbsent -> "" +| build v |+ " of type " +| demote @t |+ "" +formatValue v = "" +| build v |+ " of type " +| demote @t |+ "" -formatSomeValue :: SomeValue -> Builder -formatSomeValue (SomeValue v) = formatValue v +formatSomeValue :: (forall t. c t => SingI t) => SomeConstrainedValue c -> Builder +formatSomeValue (SomeConstrainedValue v) = formatValue v -- | Derive a 'Show' instance for a type using a custom "show" function. data ShowWith a = ShowWith (a -> String) a @@ -322,7 +318,7 @@ deriving newtype Show instance Show a => Buildable (Showing a) where - build (Showing a) = build (show @Text a) + build (Showing a) = build (Debug.show @Text a) ---------------------------------------------------------------------------- -- Time @@ -364,15 +360,16 @@ stripOptional0x :: Text -> Text stripOptional0x h = T.stripPrefix "0x" h ?: h -fromHex :: Text -> Maybe ByteString -fromHex = decodeHex . stripOptional0x +fromHex :: Text -> Either Text ByteString +fromHex hexText = + let errMsg hex = "Invalid hex: \"" <> hex <> "\"" + in maybeToRight (errMsg hexText) . decodeHex . stripOptional0x $ hexText -unsafeFromHex :: HasCallStack => Text -> ByteString -unsafeFromHex hex = fromHex hex - ?: error ("Invalid hex: " <> show hex) +parseAddressFromHex :: Text -> Either Text Address +parseAddressFromHex = fromHex >=> first pretty . parseAddressRaw ---------------------------------------------------------------------------- --- Loops +-- Traversals ---------------------------------------------------------------------------- {- | Version of 'mapM' generalized with 'L.each'. diff --git a/test-common/Test/Util/Contracts.hs b/test-common/Test/Util/Contracts.hs --- a/test-common/Test/Util/Contracts.hs +++ b/test-common/Test/Util/Contracts.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Utility functions to read sample contracts (for testing). diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Main ( main diff --git a/test/TestSuite/Cleveland/AddressRevealing.hs b/test/TestSuite/Cleveland/AddressRevealing.hs --- a/test/TestSuite/Cleveland/AddressRevealing.hs +++ b/test/TestSuite/Cleveland/AddressRevealing.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.AddressRevealing ( test_AddressRevealing ) where -import Test.Tasty +import Test.Tasty (TestTree) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/Assertions.hs b/test/TestSuite/Cleveland/Assertions.hs --- a/test/TestSuite/Cleveland/Assertions.hs +++ b/test/TestSuite/Cleveland/Assertions.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Assertions ( test_failure_fails @@ -92,12 +91,12 @@ test_checkComparesWith_fails :: TestTree test_checkComparesWith_fails = testScenario "`checkComparesWith` fails when the comparison fails and prints values" $ scenario do - checkComparesWith @Int toCardinal 1 elem (show . fmap toOrdinal) [2, 3] + checkComparesWith @Int toCardinal 1 elem (pretty . fmap toOrdinal) [2, 3] & shouldFailWithMessage [i| ━━ lhs ━━ One ━━ rhs ━━ -["Second","Third"]|] +[Second,Third]|] where toCardinal = \case 1 -> "One" diff --git a/test/TestSuite/Cleveland/BalanceCheck.hs b/test/TestSuite/Cleveland/BalanceCheck.hs --- a/test/TestSuite/Cleveland/BalanceCheck.hs +++ b/test/TestSuite/Cleveland/BalanceCheck.hs @@ -1,15 +1,16 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.BalanceCheck ( test_BalanceCheck , test_EmptyBalanceCheck ) where -import Test.Tasty +import Test.Tasty (TestTree) import Morley.Tezos.Address (Address) +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types import Test.Cleveland test_BalanceCheck :: TestTree @@ -24,8 +25,7 @@ test_EmptyBalanceCheck :: TestTree test_EmptyBalanceCheck = testScenario "An empty address' balance can be checked" $ scenario do - test <- newFreshAddress auto - dummy <- newFreshAddress auto + test ::< dummy ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto -- Doing something in order not to get "validating empty scenario" error transferMoney dummy 1 diff --git a/test/TestSuite/Cleveland/BatchOperation.hs b/test/TestSuite/Cleveland/BatchOperation.hs --- a/test/TestSuite/Cleveland/BatchOperation.hs +++ b/test/TestSuite/Cleveland/BatchOperation.hs @@ -1,17 +1,20 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.BatchOperation ( test_SomeCases ) where -import Test.Tasty +import Test.Tasty (TestTree) -import Lorentz.Value +import Morley.Tezos.Core (Mutez, mkMutez) +import Morley.Util.SizedList qualified as SL import Test.Cleveland import Test.Cleveland.Lorentz.Consumer +unsafeMkMutez' :: Natural -> Mutez +unsafeMkMutez' = either error id . mkMutez + test_SomeCases :: [TestTree] test_SomeCases = [ testScenario "Origination and transfer within a batch work" $ scenario do @@ -29,14 +32,13 @@ , testScenario "Loops within batch work" $ scenario do - test1 :: Address <- newFreshAddress auto - test2 :: Address <- newFreshAddress auto + addresses <- traverse newFreshAddress $ SL.replicateT @5 auto + let balances = SL.generate $ \i -> unsafeMkMutez' $ (i + 1) * 100 inBatch $ do - for_ [(test1, 100), (test2, 200)] $ uncurry transferMoney + for_ (SL.zip addresses balances) $ uncurry transferMoney - getBalance test1 @@== 100 - getBalance test2 @@== 200 + traverse getBalance addresses @@== balances , testScenario "Can return multiple values from a batch" $ scenario do diff --git a/test/TestSuite/Cleveland/BatchTransferCheck.hs b/test/TestSuite/Cleveland/BatchTransferCheck.hs --- a/test/TestSuite/Cleveland/BatchTransferCheck.hs +++ b/test/TestSuite/Cleveland/BatchTransferCheck.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE ApplicativeDo #-} @@ -9,17 +8,18 @@ , test_BatchTransferLeapingCosts ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz ((#), (:->)) -import qualified Lorentz as L +import Lorentz qualified as L +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types import Test.Cleveland test_SimpleTransfer :: TestTree test_SimpleTransfer = testScenario "Check the batch transaction correctness" $ scenario do - test1 <- newFreshAddress auto - test2 <- newFreshAddress auto + addrs@(test1 ::< test2 ::< Nil') <- traverse newFreshAddress $ SL.replicateT auto comment "balance is updated after batch transfer" inBatch $ do @@ -27,12 +27,11 @@ transferMoney test2 300 return () - getBalance test1 @@== 300 - getBalance test2 @@== 300 + traverse getBalance addrs @@== 300 :< 300 :< Nil -- | Add given element on stack once on first invocation, and 10k times on -- subsequent invocations. -leapingContract :: forall a. (L.NiceParameterFull a, L.NiceStorage [a], L.Dupable a) => L.Contract a [a] () +leapingContract :: forall a. (L.NiceParameterFull a, L.NiceStorageFull [a], L.Dupable a) => L.Contract a [a] () leapingContract = L.defaultContract $ L.unpair # L.duupX @2 # L.size # L.int # L.ifEq0 (L.push 1) (L.push 5000) # diff --git a/test/TestSuite/Cleveland/BlockIntervalGetter.hs b/test/TestSuite/Cleveland/BlockIntervalGetter.hs --- a/test/TestSuite/Cleveland/BlockIntervalGetter.hs +++ b/test/TestSuite/Cleveland/BlockIntervalGetter.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.BlockIntervalGetter ( test_BlockIntervalGetter ) where -import Test.Tasty +import Test.Tasty (TestTree) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/BytesSigning.hs b/test/TestSuite/Cleveland/BytesSigning.hs --- a/test/TestSuite/Cleveland/BytesSigning.hs +++ b/test/TestSuite/Cleveland/BytesSigning.hs @@ -1,16 +1,16 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.BytesSigning ( test_BytesSigning ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz ((#)) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Tezos.Crypto +import Morley.Util.SizedList.Types import Test.Cleveland checkSignatureContract :: L.Contract (PublicKey, (L.TSignature ByteString, ByteString)) () () @@ -23,8 +23,7 @@ test_BytesSigning :: TestTree test_BytesSigning = testScenario "Bytestrings can be signed" $ scenario do - dummy <- newFreshAddress "user" - signer <- newFreshAddress "signer" + dummy :< signer :< Nil <- traverse newFreshAddress $ "user" :< "signer" :< Nil helper <- originateSimple "helper" () checkSignatureContract diff --git a/test/TestSuite/Cleveland/CallStack.hs b/test/TestSuite/Cleveland/CallStack.hs --- a/test/TestSuite/Cleveland/CallStack.hs +++ b/test/TestSuite/Cleveland/CallStack.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedLists #-} @@ -12,25 +11,26 @@ ) where import Lorentz hiding (assert, comment, not) +import Lorentz qualified as L +import Unsafe qualified import Data.Char (isNumber, isSpace) -import qualified Data.List as List +import Data.List qualified as List import Fmt ((+|), (|+)) import Hedgehog (Property, property) import Servant.Client (BaseUrl(BaseUrl), ClientEnv(baseUrl), ClientError(ConnectionError), Scheme(Http)) import System.FilePath (()) -import Test.Hspec.Expectations -import Test.Tasty -import Test.Tasty.HUnit +import Test.Hspec.Expectations (shouldContain) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure) import Test.Tasty.Runners (Result(resultDescription)) import Time (sec) -import qualified Unsafe import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL, mkAlias) import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue) -import Morley.Tezos.Address (unsafeParseAddress) +import Morley.Tezos.Address (parseAddress) import Morley.Util.Interpolate (lit) import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL) @@ -489,6 +489,29 @@ |] do void getLevel + , testFailureIncludesCallStack "callstack points to runCode" + [lit| + void $ runCode RunCode + { rcContract = + L.defaultContract @() @() $ L.failUsing @MText "Contract should fail" + , rcStorage = NotRPC () + , rcParameter = NotRPC () + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + |] + do + void $ runCode RunCode + { rcContract = + L.defaultContract @() @() $ L.failUsing @MText "Contract should fail" + , rcStorage = NotRPC () + , rcParameter = NotRPC () + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } , testFailureIncludesCallStackOnEmulator "when a branchout branch throws, the callstack points to the function inside the branch" [lit| @@ -613,7 +636,7 @@ Left @Integer 1 & evalRight \_ -> "" , testGroup "callstack points to a method at its top" - [ testFailureIncludesCallStack' "callstack points to helper using @==" + [ testFailureIncludesCallStack "callstack points to helper using @==" [lit| bulkCheck [0, 1] [0, 2] ^^^^^^^^^^^^^^^^^^^^^^^ @@ -627,11 +650,38 @@ bulkCheck [0, 1] [0, 2] ] + , testGroup "callstack points to a reasonable location" + [ testFailureIncludesCallStackOnEmulator "with whenEmulation" + [lit| + runIO (throwM DummyException) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + |] + do + whenEmulation $ + runIO (throwM DummyException) + , testFailureIncludesCallStack "with ifEmulation" + [lit| + (runIO (throwM DummyException)) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + |] + do + ifEmulation + (runIO (throwM DummyException)) + (runIO (throwM DummyException)) + , testFailureIncludesCallStackOnNetwork "with whenNetwork" + [lit| + runIO (throwM DummyException) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + |] + do + whenNetwork $ + runIO (throwM DummyException) + ] ] where invalidAlias = mkAlias "UnknownAlias" - invalidAddr = unsafeParseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC" + invalidAddr = unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC" invalidTAddr = TAddress @() invalidAddr test_callStack_property :: TestTree @@ -657,26 +707,16 @@ dummyPropWithNestedPureError ] -testFailureIncludesCallStack - :: HasCallStack - => TestName - -> String - -> (forall caps m. MonadCleveland caps m => m ()) - -> TestTree -testFailureIncludesCallStack testName = - testFailureIncludesCallStack' - testName - -- | Check that exceptions thrown by the given function contain a callstack that points to that function. -- -- The scenario is run on both the emulator and on a network. -testFailureIncludesCallStack' +testFailureIncludesCallStack :: HasCallStack => TestName -> String -> (forall caps m. MonadCleveland caps m => m ()) -> TestTree -testFailureIncludesCallStack' testName expectedErrorLines test = +testFailureIncludesCallStack testName expectedErrorLines test = testGroup testName [ testFailureIncludesCallStackOnEmulator "On emulator" diff --git a/test/TestSuite/Cleveland/ChainIdGet.hs b/test/TestSuite/Cleveland/ChainIdGet.hs --- a/test/TestSuite/Cleveland/ChainIdGet.hs +++ b/test/TestSuite/Cleveland/ChainIdGet.hs @@ -1,15 +1,14 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.ChainIdGet ( test_ChainIdGet ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz ((#)) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Tezos.Core (ChainId, dummyChainId) import Morley.Util.Named import Test.Cleveland diff --git a/test/TestSuite/Cleveland/ContractAllocation.hs b/test/TestSuite/Cleveland/ContractAllocation.hs --- a/test/TestSuite/Cleveland/ContractAllocation.hs +++ b/test/TestSuite/Cleveland/ContractAllocation.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.ContractAllocation ( test_ContractAllocation ) where -import Test.Tasty +import Test.Tasty (TestTree) import Morley.Tezos.Address (Address) import Morley.Util.Named diff --git a/test/TestSuite/Cleveland/DFS.hs b/test/TestSuite/Cleveland/DFS.hs --- a/test/TestSuite/Cleveland/DFS.hs +++ b/test/TestSuite/Cleveland/DFS.hs @@ -1,17 +1,16 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.DFS ( test_CheckDFSExecutionOrder ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz.Address import Lorentz.Entrypoints -import qualified Morley.Michelson.Typed as T -import Morley.Tezos.Core (Mutez, toMutez) +import Morley.Michelson.Typed qualified as T +import Morley.Tezos.Core (Mutez) import Test.Cleveland import Test.Util.Contracts (inContractsDir) @@ -59,9 +58,9 @@ >>= originateSimple @TransferAllCallerParameter "transfer_all_caller" () . noViews transfer $ TransferData { tdTo = transferAllAddr - , tdAmount = toMutez 100 + , tdAmount = 100 , tdEntrypoint = ep "receiveXtz" , tdParameter = () - } -- transferAllAddr (toMutez 100) + } -- transferAllAddr 100 call transferAllCallerAddr (Call @"CallCPS") (toTAddress transferAllAddr) ] diff --git a/test/TestSuite/Cleveland/Emulated.hs b/test/TestSuite/Cleveland/Emulated.hs --- a/test/TestSuite/Cleveland/Emulated.hs +++ b/test/TestSuite/Cleveland/Emulated.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Emulated ( test_Emulated ) where -import Test.Tasty +import Test.Tasty (TestTree, testGroup) import Morley.Tezos.Address import Test.Cleveland @@ -51,7 +50,7 @@ , testScenarioOnEmulator "adds branch name to error" $ scenarioEmulated do branchout [ "" ?- void $ - signBytes "" (unsafeParseAddress "tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM") + signBytes "" (unsafe $ parseAddress "tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM") ] & shouldFailWithMessage "" ] diff --git a/test/TestSuite/Cleveland/Entrypoints.hs b/test/TestSuite/Cleveland/Entrypoints.hs --- a/test/TestSuite/Cleveland/Entrypoints.hs +++ b/test/TestSuite/Cleveland/Entrypoints.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Entrypoints ( test_duplicateEntrypoints ) where -import Test.Tasty.Runners +import Test.Tasty (TestTree) import Morley.Michelson.Untyped @@ -16,10 +15,10 @@ test_duplicateEntrypoints :: TestTree test_duplicateEntrypoints = testContractMatchesEntrypoints "Ill-typed contract fails the test" illTypedContract mempty - & expectFailure "Duplicated entrypoint names: 'do1'" + & expectFailure "invalid parameter declaration: Duplicated entrypoint names: 'do1'" where - n = unsafeMkAnnotation "" - do1 = unsafeMkAnnotation "do1" + n = unsafe $ mkAnnotation "" + do1 = unsafe $ mkAnnotation "do1" illTypedContract = Contract { contractParameter = ParameterType ( diff --git a/test/TestSuite/Cleveland/ExpectFailure.hs b/test/TestSuite/Cleveland/ExpectFailure.hs --- a/test/TestSuite/Cleveland/ExpectFailure.hs +++ b/test/TestSuite/Cleveland/ExpectFailure.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -16,13 +15,13 @@ import Data.Either.Validation (Validation(Success)) import Fmt (Builder, jsonListF', pretty, unlinesF) -import Hedgehog hiding (failure) -import qualified Hedgehog.Gen as Gen -import Test.Tasty +import Hedgehog (Gen, Property, PropertyT, forAllWith, property) +import Hedgehog.Gen qualified as Gen +import Test.Tasty (TestTree, testGroup) import Morley.Micheline (toExpression) import Morley.Michelson.Runtime.GState (genesisAddress1) -import Morley.Tezos.Address (unsafeParseAddress) +import Morley.Tezos.Address (parseAddress) import Morley.Tezos.Core (parseChainId) import Morley.Util.Interpolate (i) import Test.Cleveland @@ -32,7 +31,7 @@ import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..)) import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Internal.Pure (emptyScenarioBranch) -import Test.Cleveland.Util (failedTest, unsafeFromHex) +import Test.Cleveland.Util (failedTest, fromHex) import TestSuite.Util (shouldFailWithMessage) test_CatchExceptions :: TestTree @@ -151,7 +150,7 @@ FailedInBranch emptyScenarioBranch $ SomeException $ WithCallStack callStack $ SomeException $ FailedInBranch emptyScenarioBranch $ SomeException $ - TransferFailure (unsafeParseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") BadParameter + TransferFailure (unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") BadParameter res <- attempt @TransferFailure action @@ -213,7 +212,7 @@ , #cTriggerFailWithCustomErrorNoArg /-> failCustomNoArg #customErrorNoArg , #cTriggerFailWithRightCombedPair /-> push @(Natural, (Natural, Natural)) (1, (2, 3)) # failWith , #cTriggerFailWithChainIdStr /-> push @MText "NetXUdfLh6Gm88t" # failWith - , #cTriggerFailWithChainIdBytes /-> push @ByteString (unsafeFromHex "458aa837") # failWith + , #cTriggerFailWithChainIdBytes /-> push @ByteString (unsafe $ fromHex "458aa837") # failWith ) type instance ErrorArg "customError" = Natural diff --git a/test/TestSuite/Cleveland/FailureLogs.hs b/test/TestSuite/Cleveland/FailureLogs.hs --- a/test/TestSuite/Cleveland/FailureLogs.hs +++ b/test/TestSuite/Cleveland/FailureLogs.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2022 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.FailureLogs ( test_FailureLogs ) where -import qualified Lorentz as L hiding (comment) +import Lorentz qualified as L hiding (comment) import Test.Tasty (TestTree) diff --git a/test/TestSuite/Cleveland/Import.hs b/test/TestSuite/Cleveland/Import.hs --- a/test/TestSuite/Cleveland/Import.hs +++ b/test/TestSuite/Cleveland/Import.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests on importing functionality. module TestSuite.Cleveland.Import @@ -14,7 +13,7 @@ , test_EmbedMutez ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz.Value (Address, Mutez) import Morley.Tezos.Address (ta) diff --git a/test/TestSuite/Cleveland/InitialState.hs b/test/TestSuite/Cleveland/InitialState.hs --- a/test/TestSuite/Cleveland/InitialState.hs +++ b/test/TestSuite/Cleveland/InitialState.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Tests for the initial state configuration of emulated scenarios diff --git a/test/TestSuite/Cleveland/Level.hs b/test/TestSuite/Cleveland/Level.hs --- a/test/TestSuite/Cleveland/Level.hs +++ b/test/TestSuite/Cleveland/Level.hs @@ -1,40 +1,38 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Level ( test_CompareLevels , test_Level ) where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestTree, testGroup) import Morley.Michelson.Runtime.Dummy (dummyLevel) import Test.Cleveland -import Test.Cleveland.Internal.Abstract (EmulatedCaps) -- | Smart comparison for levels. -- -- In a run against real chain, level can manage to advance during the test -- execution, so we have to allow inaccuracy in return values of @getLevel@. compareLevels - :: RunMode caps - -> Natural -- ^ Level we got + :: MonadCleveland caps m + => Natural -- ^ Level we got -> Natural -- ^ Expected level - -> Bool -compareLevels = \case - EmulationMode -> (==) - NetworkMode -> \got expected -> and [got >= expected, got <= expected + 1] + -> m Bool +compareLevels x y = do + cmp <- ifEmulation (pure (==)) (pure \got expected -> and [got >= expected, got <= expected + 1]) + pure $ cmp x y -test_CompareLevels :: TestTree +test_CompareLevels :: [TestTree] test_CompareLevels = - testCase "compareLevels allows the desired numbers" do - compareLevels (EmulationMode @(EmulatedCaps PureM)) 5 5 @?= True - compareLevels (EmulationMode @(EmulatedCaps PureM)) 6 5 @?= False - - compareLevels NetworkMode 5 5 @?= True - compareLevels NetworkMode 6 5 @?= True + [ testScenarioOnEmulator "compareLevels allows the desired numbers on emulator" $ scenario do + compareLevels 5 5 @@== True + compareLevels 6 5 @@== False + , testScenarioOnNetwork "compareLevels allows the desired numbers on network" $ scenario do + compareLevels 5 5 @@== True + compareLevels 6 5 @@== True + ] test_Level :: TestTree test_Level = @@ -47,8 +45,8 @@ advanceLevel delta l1 <- getLevel - runMode <- getRunMode - assert (compareLevels runMode l1 (l0 + delta)) $ + result <- compareLevels l1 (l0 + delta) + assert result $ mconcat [ "Expected exactly " , show delta @@ -65,8 +63,8 @@ advanceToLevel (l0 + delta) l1 <- getLevel - runMode <- getRunMode - assert (compareLevels runMode l1 (l0 + delta)) $ + result <- compareLevels l1 (l0 + delta) + assert result $ mconcat [ "Expected to be at level " , show (l0 + delta) @@ -79,8 +77,8 @@ advanceToLevel (fromInteger $ (fromIntegral @_ @Integer l0) - 4) l1 <- getLevel - runMode <- getRunMode - assert (compareLevels runMode l1 l0) $ + result <- compareLevels l1 l0 + assert result $ mconcat [ "Expected to be at level " , show l0 diff --git a/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs b/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs --- a/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs +++ b/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator ( allocatorContract diff --git a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs --- a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +++ b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- To avoid explicitly depending on @containers@ {-# LANGUAGE OverloadedLists #-} @@ -13,20 +12,22 @@ , expectFailure ) where -import qualified Lorentz as L +import Lorentz qualified as L import Data.List (isInfixOf) +import Data.Text (strip) import Test.Tasty (testGroup) -import Test.Tasty.HUnit +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) import Test.Tasty.Providers (IsTest, run) -import Test.Tasty.Runners +import Test.Tasty.Runners (FailureReason(..), Outcome(..), Result(..), TestTree(..)) import Lorentz.Annotation import Lorentz.Constraints import Lorentz.Entrypoints import Lorentz.Run import Lorentz.Value -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U +import Morley.Util.Interpolate import Test.Cleveland.Lorentz.Entrypoints @@ -36,13 +37,13 @@ | Do3 MyEntrypoints2 | Do4 MyParams deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyEntrypoints2 = Do10 | Do11 Natural deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) data MyParams = MyParams { param1 :: () @@ -74,8 +75,8 @@ epSpecFull = epSpecPartial <> [ ( U.UnsafeEpName "do4" , U.Ty ( - U.TPair (U.unsafeMkAnnotation "param1") - (U.unsafeMkAnnotation "param2") + U.TPair (unsafe $ U.mkAnnotation "param1") + (unsafe $ U.mkAnnotation "param2") def def (U.Ty U.TUnit def) @@ -98,7 +99,7 @@ assertBool "Result is failure" $ case resultOutcome of Failure TestFailed -> True _ -> False - if str `isInfixOf` resultDescription + if (strip <$> lines (toText str)) `isInfixOf` (strip <$> lines (toText resultDescription)) then pass else assertFailure $ "Expected '" <> resultDescription <> "' to contain '" <> str <> "'" @@ -110,13 +111,25 @@ , testContractCoversEntrypoints "testContractCoversEntrypoints fails on wrong type" (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] - & expectFailure "Expected: nat" + & expectFailure "Expected: nat\nActual: int" , testContractCoversEntrypoints "testContractCoversEntrypoints fails on missing entrypoints" (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] - & expectFailure "Missing entrypoints in the contract: do123" + & expectFailure "Entrypoints do not match specification: \ + \Missing entrypoints in the contract: do123: int" ] +genBigPair :: Int -> U.Ty +genBigPair 0 = U.Ty U.TBytes def +genBigPair n = U.Ty ( + U.TPair (unsafe $ U.mkAnnotation "param1") + (unsafe $ U.mkAnnotation "param2") + def + def + (U.Ty U.TUnit def) + (genBigPair (n - 1)) + ) def + test_ContractMatchEntrypoints :: [TestTree] test_ContractMatchEntrypoints = [ testContractMatchesEntrypoints @@ -124,16 +137,30 @@ , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on wrong type" (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] - & expectFailure "Expected: nat" + & expectFailure "Expected: nat\nActual: int" , testContractMatchesEntrypoints + "testContractMatchesEntrypoints fails on wrong nested type" + (dummyContract @MyEntrypoints1) [( U.UnsafeEpName "do4", genBigPair 6)] + & expectFailure [it| + pair (unit %param1) + - (pair %param2 (unit %param1) + - (pair %param2 (unit %param1) + - (pair %param2 (unit %param1) + - (pair %param2 (unit %param1) + - (pair %param2 + - (unit %param1) + - (bytes %param2)))))) + + (bytes %param2) + |] + , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on missing entrypoints" (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] - & expectFailure "Missing entrypoints in the contract: do123" + & expectFailure "Missing entrypoints in the contract: do123: int" , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on extraneous entrypoints" (dummyContract @MyEntrypoints1) epSpecPartial - & expectFailure "Extraneous entrypoints in the contract: do4:\ - \ pair (unit %param1) (bytes %param2)" + & expectFailure "Entrypoints do not match specification:\ + \ Extraneous entrypoints in the contract: do4: pair (unit %param1) (bytes %param2)" ] test_ContractMatchEntrypointsT :: [TestTree] @@ -142,7 +169,12 @@ "testContractMatchesEntrypointsT works as expected" (dummyContract @MyEntrypoints1) , testContractMatchesEntrypointsT @MyEntrypoints2 "testContractMatchesEntrypointsT fails on extra entrypoints" (dummyContract @MyEntrypoints1) - & expectFailure "Extraneous entrypoints in the contract" + & expectFailure [it| + Extraneous entrypoints in the contract: + do1: int + do2: pair int int + do4: pair (unit %param1) (bytes %param2) + |] ] test_ContractCoverEntrypointsT :: [TestTree] diff --git a/test/TestSuite/Cleveland/MismatchError.hs b/test/TestSuite/Cleveland/MismatchError.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/MismatchError.hs @@ -0,0 +1,114 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.MismatchError + ( unit_UnexpectedStorageType + , unit_UnexpectedTLT + , unit_UnexpectedStorageTypeSimple + , unit_UnexpectedTLTSimple + , unit_StackEqErrorSimple + , unit_StackEqError + ) where + +import Fmt (pretty) +import Test.Tasty.HUnit (Assertion, (@?=)) + +import Morley.Michelson.TypeCheck.Error +import Morley.Michelson.Typed qualified as T +import Morley.Util.Interpolate +import Morley.Util.MismatchError + +import Test.Cleveland.Internal.Pure + +unit_UnexpectedStorageTypeSimple :: Assertion +unit_UnexpectedStorageTypeSimple = do + pretty ( + UnexpectedStorageType MkMismatchError + { meExpected = T.TInt, meActual = T.TUnit }) + @?= expectedSimple + +unit_UnexpectedTLTSimple :: Assertion +unit_UnexpectedTLTSimple = do + pretty ( + UnexpectedTopLevelType TltStorageType + MkMismatchError { meExpected = T.TInt, meActual = T.TUnit }) + @?= expectedSimple + +unit_StackEqErrorSimple :: Assertion +unit_StackEqErrorSimple = do + pretty @_ @Text ( + StackEqError + MkMismatchError { meExpected = [T.TInt], meActual = [T.TUnit] }) + @?= [itu| + Stacks not equal: + Expected: [int] + Actual: [unit] + |] + +unit_UnexpectedStorageType :: Assertion +unit_UnexpectedStorageType = do + pretty ( + UnexpectedStorageType MkMismatchError + { meExpected = T.TInt, meActual = T.TPair T.TUnit (T.TPair T.TNat T.TBytes) }) + @?= expected + +unit_UnexpectedTLT :: Assertion +unit_UnexpectedTLT = do + pretty ( + UnexpectedTopLevelType TltStorageType + MkMismatchError { meExpected = T.TInt, meActual = T.TPair T.TUnit (T.TPair T.TNat T.TBytes) }) + @?= expected + +unit_StackEqError :: Assertion +unit_StackEqError = do + pretty @_ @Text ( + StackEqError + MkMismatchError + { meExpected = + [ T.TPair T.TInt (T.TPair T.TNat T.TBytes) + , T.TPair T.TNat (T.TPair T.TUnit T.TBool)] + , meActual = + [ T.TPair T.TUnit (T.TPair T.TNat T.TBytes) + , T.TPair T.TNat (T.TPair T.TInt T.TBool) + , T.TPair T.TNat T.TNat + ]}) + @?= [itu| + Stacks not equal: + Expected: [pair int nat bytes, pair nat unit bool] + Actual: [pair unit nat bytes, pair nat int bool, pair nat nat] + Mismatch: + --- expected +++ actual + - [ pair int + + [ pair unit + nat + bytes + , pair nat + - unit + + int + bool + + , pair nat + + nat + ] + |] + +expectedSimple :: Text +expectedSimple = [itu| + Unexpected storage type. + Expected: int + Actual: unit + |] + +expected :: Text +expected = [itu| + Unexpected storage type. + Expected: int + Actual: pair unit + nat + bytes + Mismatch: + --- expected +++ actual + - int + + pair unit + + nat + + bytes + |] diff --git a/test/TestSuite/Cleveland/NewAddressCheck.hs b/test/TestSuite/Cleveland/NewAddressCheck.hs --- a/test/TestSuite/Cleveland/NewAddressCheck.hs +++ b/test/TestSuite/Cleveland/NewAddressCheck.hs @@ -1,15 +1,16 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.NewAddressCheck ( test_AddressesReuse , test_NewAddressCheck ) where -import Test.Tasty +import Test.Tasty (TestTree) import Morley.Tezos.Core +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types import Test.Cleveland test_AddressesReuse :: TestTree @@ -19,16 +20,14 @@ -- If probability of generating the same address twice is low, then -- we better always blindly transfer some money to new addresses. testScenario "Address generation is deterministic" $ scenario do - addr1 <- newAddress "test" - addr2 <- newAddress "test" + addr1 ::< addr2 ::< Nil' <- traverse newAddress $ SL.replicateT "test" addr1 @== addr2 test_NewAddressCheck :: [TestTree] test_NewAddressCheck = [ testScenario "Newly created address gets money if it had low balance" $ scenario do - test <- newAddress "test" - test2 <- newAddress "test2" + test :< test2 :< Nil <- traverse newAddress $ "test" :< "test2" :< Nil balance <- getBalance test let diff --git a/test/TestSuite/Cleveland/OperationReplay.hs b/test/TestSuite/Cleveland/OperationReplay.hs --- a/test/TestSuite/Cleveland/OperationReplay.hs +++ b/test/TestSuite/Cleveland/OperationReplay.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.OperationReplay ( test_replayOrigination_fails , test_replayTransfer_fails ) where -import Test.Tasty +import Test.Tasty (TestTree) import Morley.Tezos.Address (Address) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/PrefixNetworkScenario.hs b/test/TestSuite/Cleveland/PrefixNetworkScenario.hs --- a/test/TestSuite/Cleveland/PrefixNetworkScenario.hs +++ b/test/TestSuite/Cleveland/PrefixNetworkScenario.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.PrefixNetworkScenario ( test_PrefixNetworkScenario @@ -8,15 +7,16 @@ import Data.Fixed (Nano) import Data.Text (takeEnd) -import Data.Time.Clock.POSIX +import Data.Time.Clock.POSIX (getPOSIXTime) +import System.IO.Temp (withSystemTempDirectory) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@=?)) import Morley.Client as Client -import Morley.Client.TezosClient.Types (tceAliasPrefixL) +import Morley.Client.TezosClient.Types (tceAliasPrefixL, tceMbTezosClientDataDirL) import Morley.Tezos.Crypto (SecretKey, detSecretKey) import Test.Cleveland -import Test.Cleveland.Internal.Abstract (HasClevelandCaps(moneybagL), Moneybag(Moneybag)) +import Test.Cleveland.Internal.Abstract (Moneybag(Moneybag), moneybagL) import Test.Cleveland.Internal.Client (neMoneybagAliasL, neMorleyClientEnvL, neSecretKeyL, runClevelandT) import Test.Cleveland.Tasty (modifyNetworkEnv, whenNetworkEnabled) @@ -33,6 +33,9 @@ . (neSecretKeyL .~ Just sk) . (neMoneybagAliasL .~ aliasName) +setTmpDir :: FilePath -> NetworkEnv -> NetworkEnv +setTmpDir dir = neMorleyClientEnvL . mceTezosClientL . tceMbTezosClientDataDirL .~ Just dir + test_PrefixNetworkScenario :: IO TestTree test_PrefixNetworkScenario = do -- use 7 digits of the current POSIX time in nanoseconds to generate seed @@ -41,9 +44,14 @@ seed <- encodeUtf8 . takeEnd 7 . show @Text . realToFrac @_ @Nano <$> getPOSIXTime let key = detSecretKey seed pure $ mangleNetworkEnv key $ whenNetworkEnabled $ \withEnv -> - testCase "Moneybag alias is not affected by alias prefix" $ withEnv $ \env -> do - Moneybag moneybagAddress <- runClevelandT env $ view moneybagL + testCase "Moneybag alias is not affected by alias prefix" $ withEnv $ \env' -> + -- NB: we can't have 'withSystemTempDirectory' outside the test because + -- the outer IO action finishes before the test itself is run. + -- hence we have to change the tmpdir in env inside the test too + withSystemTempDirectory "tezos-client" \tmpdir -> do + let env = setTmpDir tmpdir env' + Moneybag moneybagAddress <- runClevelandT env $ view moneybagL - actualAlias <- runMorleyClientM (neMorleyClientEnv env) $ - Client.getAlias $ AddressResolved moneybagAddress - actualAlias @=? aliasName + actualAlias <- runMorleyClientM (neMorleyClientEnv env) $ + Client.getAlias $ AddressResolved moneybagAddress + actualAlias @=? aliasName diff --git a/test/TestSuite/Cleveland/PrettyFailWith.hs b/test/TestSuite/Cleveland/PrettyFailWith.hs --- a/test/TestSuite/Cleveland/PrettyFailWith.hs +++ b/test/TestSuite/Cleveland/PrettyFailWith.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.PrettyFailWith ( test_PrettyFailWith diff --git a/test/TestSuite/Cleveland/PublicKeyToAddress.hs b/test/TestSuite/Cleveland/PublicKeyToAddress.hs --- a/test/TestSuite/Cleveland/PublicKeyToAddress.hs +++ b/test/TestSuite/Cleveland/PublicKeyToAddress.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Test for the calculation of an address from its public key. See [#354] module TestSuite.Cleveland.PublicKeyToAddress @@ -8,11 +7,11 @@ ) where import Hedgehog (forAll, property, withTests) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) -import qualified Unsafe (fromJust) +import Unsafe qualified (fromJust) import Lorentz as L hiding (comment) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/RefillableAddress.hs b/test/TestSuite/Cleveland/RefillableAddress.hs --- a/test/TestSuite/Cleveland/RefillableAddress.hs +++ b/test/TestSuite/Cleveland/RefillableAddress.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.RefillableAddress ( test_AddressRefills @@ -8,10 +7,12 @@ , test_RefillFailure ) where -import qualified Lorentz as L +import Lorentz qualified as L -import Test.Tasty +import Test.Tasty (TestTree) +import Morley.Util.SizedList qualified as SL +import Morley.Util.SizedList.Types import Test.Cleveland import Test.Util.Contracts @@ -57,17 +58,18 @@ test_AddressDoesntRefill :: [TestTree] test_AddressDoesntRefill = - [ testScenarioOnEmulator "A non-refillable address doesn't refill" $ scenarioEmulated (nonRefillableScenario emulatedError) - , testScenarioOnNetwork "A non-refillable address doesn't refill" $ scenario (nonRefillableScenario networkError) + [ testScenarioOnEmulator "A non-refillable address doesn't refill" $ + scenarioEmulated (nonRefillableScenario emulatedError) + , testScenarioOnNetwork "A non-refillable address doesn't refill" $ + scenario (nonRefillableScenario networkError) ] where emulatedError = "doesn't have enough funds" networkError = "too low" -nonRefillableScenario :: MonadCleveland caps m => String -> m () +nonRefillableScenario :: (MonadFail m, MonadCleveland caps m) => String -> m () nonRefillableScenario errorMsg = do - nonRefillable <- newFreshAddress auto - receiver <- newFreshAddress auto + nonRefillable ::< receiver ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto -- needed to reveal `nonRefillable` transferMoney nonRefillable 1 diff --git a/test/TestSuite/Cleveland/RunCode.hs b/test/TestSuite/Cleveland/RunCode.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/RunCode.hs @@ -0,0 +1,280 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- Disable the warning generated by the `L.source` instruction. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +module TestSuite.Cleveland.RunCode + ( test_runs_code + , test_emulator_state_is_not_modified + , test_other_operations_are_not_executed + , test_handles_bigmap + , test_handles_bigmap_ids + , test_env_vars_can_be_observed + , test_can_observe_existing_onchain_contracts_and_accounts + , test_self_address_does_not_exist_onchain + ) where + +import Control.Lens (at) +import Debug qualified (show) +import Test.Tasty (TestTree) + +import Lorentz (HasAnnotation) +import Lorentz qualified as L +import Lorentz.Base +import Lorentz.Value +import Morley.Michelson.Runtime.GState (gsAddressesL) +import Test.Cleveland +import Test.Cleveland.Internal.Pure (psGState) +import TestSuite.Util (idContract) + +test_runs_code :: TestTree +test_runs_code = + testScenario "runs the given contract's code" $ scenario do + runCode RunCode + { rcContract = increment + , rcStorage = NotRPC 5 + , rcParameter = NotRPC 3 + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } @@== 8 + where + increment :: Contract Integer Integer () + increment = L.defaultContract $ + L.unpair + # L.add + # L.nil # L.pair + +test_emulator_state_is_not_modified :: TestTree +test_emulator_state_is_not_modified = + testScenarioOnEmulator "the emulator's state is not modified" $ scenario do + before <- use psGState + runCode RunCode + { rcContract = transferToSender + , rcStorage = NotRPC () + , rcParameter = NotRPC () + , rcAmount = 900 + , rcBalance = 900 + , rcSource = Nothing + } + after <- use psGState + checkComparesWith Debug.show before (==) Debug.show after + where + transferToSender :: Contract () () () + transferToSender = L.defaultContract $ + L.drop + # L.sender + # L.contract @() + # L.assertSome @MText "Address's parameter is not of type unit." + # L.push @Mutez 10 + # L.push () + # L.transferTokens + # L.dip (L.nil) # L.cons + # L.dip (L.push ()) # L.pair + +test_other_operations_are_not_executed :: TestTree +test_other_operations_are_not_executed = + testScenario "other operations are not executed" $ scenario do + -- If we originated the contract and called it, it would loop + -- until it ran out of gas. + + -- But because `runCode` is not supposed to execute operations emitted by the first call, + -- then the counter should only be increased to 1 and then stop. + runCode RunCode + { rcContract = unboundRecursion + , rcStorage = NotRPC 0 + , rcParameter = NotRPC () + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } @@== 1 + where + -- | A contract that calls itself forever, increment the counter in its storage by 1 on every call. + unboundRecursion :: Contract () Integer () + unboundRecursion = L.defaultContract $ + L.cdr + # L.push @Integer 1 # L.add + # L.self @() + # L.push @Mutez 0 + # L.push () + # L.transferTokens + # L.dip L.nil # L.cons + # L.pair + +test_handles_bigmap :: TestTree +test_handles_bigmap = + testScenario "handles bigmaps in parameter/storage" $ scenario do + (total, bigMapId) <- runCode RunCode + { rcContract = lookupBigMapKey + , rcStorage = NotRPC ((0, 0), one ("key", 50)) + , rcParameter = NotRPC ("key", one ("key", 20)) + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } + + total @== (50, 20) + -- Check that the bigmap was not actually created on-chain. + getBigMapValueMaybe bigMapId "key" @@== Nothing + +test_handles_bigmap_ids :: TestTree +test_handles_bigmap_ids = + testScenario "handles bigmap IDs in parameter/storage" $ scenario do + -- Originate a contract with a big_map in its storage + -- in order to actually create a valid on-chain bigmap ID. + handle <- originateSimple @() @(BigMap MText Integer) @() "bigmap" (one ("key", 30)) idContract + bigMapId <- getStorage handle + + (total, _) <- runCode RunCode + { rcContract = lookupBigMapKey + , rcStorage = IsRPC ((0, 0), bigMapId) + , rcParameter = IsRPC ("key", bigMapId) + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } + + total @== (30, 30) + +test_env_vars_can_be_observed :: TestTree +test_env_vars_can_be_observed = + testScenario "environment variables can be observed" $ scenario do + sender <- newFreshAddress auto + source <- newFreshAddress auto + + envVars <- withSender sender $ runCode RunCode + { rcContract = readEnvVars + , rcStorage = NotRPC Nothing + , rcParameter = NotRPC () + , rcAmount = 456 + , rcBalance = 123 + , rcSource = Just source + } >>= evalJust "Expected contract to return a `Some`" + + getLevel @@== envLevel envVars + getChainId @@== envChainId envVars + envSender envVars @== sender + envSource envVars @== source + envAmount envVars @== 456 + envBalance envVars @== 123 + where + readEnvVars :: Contract () (Maybe EnvVars) () + readEnvVars = L.defaultContract $ + L.drop + # L.constructT @EnvVars + ( L.fieldCtor $ L.level + , L.fieldCtor $ L.chainId + , L.fieldCtor $ L.sender + , L.fieldCtor $ L.source + , L.fieldCtor $ L.amount + , L.fieldCtor $ L.balance + ) + # L.some # L.nil # L.pair + +data EnvVars = EnvVars + { envLevel :: Natural + , envChainId :: ChainId + , envSender :: Address + , envSource :: Address + , envAmount :: Mutez + , envBalance :: Mutez + } + deriving stock (Generic) + deriving anyclass (IsoValue, HasAnnotation) + +instance HasRPCRepr EnvVars where type AsRPC EnvVars = EnvVars + +test_can_observe_existing_onchain_contracts_and_accounts :: TestTree +test_can_observe_existing_onchain_contracts_and_accounts = + testScenario "existing onchain contracts/acounts can be observed" $ scenario do + contractAddress <- toAddress <$> originate OriginateData + { odName = "contract" + , odBalance = 123 + , odStorage = () + , odContract = idContract @Integer @() + } + + let + checkContractExists :: Contract () (Maybe Address) () + checkContractExists = L.defaultContract $ + L.drop + -- Assert that the given address exists and belongs to a contract. + # L.push contractAddress + # L.contract @Integer + # L.assertSome @MText "Expected to find a contract with parameter `Integer`." + # L.address + # L.some # L.nil # L.pair + + runCode RunCode + { rcContract = checkContractExists + , rcStorage = IsRPC Nothing + , rcParameter = IsRPC () + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } @@== Just contractAddress + +test_self_address_does_not_exist_onchain :: TestTree +test_self_address_does_not_exist_onchain = + testScenarioOnEmulator "SELF address does not exist onchain" $ scenario do + emulatorState <- use psGState + + let + returnSelf :: Contract Integer (Maybe Address) () + returnSelf = L.defaultContract $ + L.drop + -- Check `SELF` instruction succeeds + # L.self @Integer + # L.drop + # L.selfAddress # L.contract @Integer + # L.assertSome @MText "Expected to find a contract with parameter `Integer`." + # L.address # L.some # L.nil # L.pair + + selfAddr <- runCode RunCode + { rcContract = returnSelf + , rcStorage = IsRPC Nothing + , rcParameter = IsRPC 0 + , rcAmount = 0 + , rcBalance = 0 + , rcSource = Nothing + } >>= evalJust "Expected contract to return a `Some`" + + emulatorState ^. gsAddressesL . at selfAddr @== Nothing + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | Looks up an integer in: +-- +-- * The big_map given in the parameter +-- * The big_map in the storage +-- +-- ... and stores both results in the storage. +lookupBigMapKey :: Contract (MText, BigMap MText Integer) ((Integer, Integer), BigMap MText Integer) () +lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ + L.unpair + # L.dip L.cdr + # L.unpair + # L.stackType @'[MText, BigMap MText Integer, BigMap MText Integer] + + # L.dup + # L.dip L.swap + # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer] + + -- Make a copy of the bigmap in the storage + # L.dupN @4 + # L.dug @4 + # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer, BigMap MText Integer] + + -- Retrieve keys + # L.get + # L.assertSome @MText "Expected Some, found None." + # L.dug @2 + # L.get + # L.assertSome @MText "Expected Some, found None." + + # L.pair + # L.pair + # L.nil @Operation # L.pair diff --git a/test/TestSuite/Cleveland/StorageCheck.hs b/test/TestSuite/Cleveland/StorageCheck.hs --- a/test/TestSuite/Cleveland/StorageCheck.hs +++ b/test/TestSuite/Cleveland/StorageCheck.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE OverloadedLists #-} @@ -12,15 +11,14 @@ , test_AnnotationsArePreserved ) where - -import Control.Lens +import Control.Lens (from, (^?!)) import Fmt (Buildable(..), GenericBuildable(..)) import System.FilePath (()) import Test.Tasty (TestTree) import Lorentz hiding (comment, contract) import Morley.Michelson.Typed (isoValue) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.AnnotatedValue import Test.Cleveland @@ -85,9 +83,9 @@ ] } addr <- originateSimple @() @Storage "test" initialStorage idContract - getRunMode >>= \case - NetworkMode -> _stField1RPC <$> getStorage addr @@== 23 - EmulationMode -> getFullStorage addr @@== initialStorage + ifEmulation + (getFullStorage addr @@== initialStorage) + (_stField1RPC <$> getStorage addr @@== 23) test_GetSomeStorage :: TestTree test_GetSomeStorage = testScenario "getSomeStorage is consistent with getStorage" $ scenario do diff --git a/test/TestSuite/Cleveland/StorageWithBigMaps.hs b/test/TestSuite/Cleveland/StorageWithBigMaps.hs --- a/test/TestSuite/Cleveland/StorageWithBigMaps.hs +++ b/test/TestSuite/Cleveland/StorageWithBigMaps.hs @@ -1,11 +1,13 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE OverloadedLists #-} module TestSuite.Cleveland.StorageWithBigMaps - ( test_UniqueIDs + ( test_EMPTY_BIG_MAP + , test_UPDATE + , test_DUP + , test_UniqueIDs , test_getAllBigMapValues , test_getAllBigMapValues_ConsistentWith_getBigMapValue , test_getBigMapSize @@ -21,8 +23,8 @@ import Data.Data (Data) import Data.Data.Lens (biplate) import Fmt (Builder, blockListF, unlinesF) -import Test.Tasty (TestTree) -import qualified Unsafe (fromIntegral) +import Test.Tasty (TestTree, testGroup) +import Unsafe qualified (fromIntegral) import Test.Cleveland import TestSuite.Util (idContract, saveInStorageContract) @@ -99,6 +101,111 @@ # L.swap # dip (iter (cdr # cons)) # L.drop + +test_EMPTY_BIG_MAP :: TestTree +test_EMPTY_BIG_MAP = + testScenario "EMPTY_BIG_MAP always creates a new ID" $ scenario do + forM_ contracts \c -> do + addr <- originateSimple "contract" [("a", 1)] c + id0 <- getStorage addr + call addr CallDefault () + unBigMapId <$> getStorage addr @@/= unBigMapId id0 + where + contracts :: [Contract () (BigMap MText Integer) ()] + contracts = [createEmptyBigMap, copyToEmptyBigMap] + + createEmptyBigMap :: Contract () (BigMap MText Integer) () + createEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ + L.drop + # L.emptyBigMap + # L.nil # L.pair + + copyToEmptyBigMap :: Contract () (BigMap MText Integer) () + copyToEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ + L.drop + # L.emptyBigMap @MText @Integer + # L.push @Integer 1 + # L.some + # L.push @MText "a" + # L.update + # L.nil # L.pair + +test_UPDATE :: TestTree +test_UPDATE = + testScenario "UPDATE never creates a new ID" $ scenario do + addr <- originateSimple "contract" [("12", 12)] updateBigMap + id0 <- getStorage addr + call addr CallDefault () + unBigMapId <$> getStorage addr @@== unBigMapId id0 + where + updateBigMap :: Contract () (BigMap MText Integer) () + updateBigMap = L.mkContractWith L.intactCompilationOptions $ + L.cdr + # L.push 12 # L.some + # L.push "12" + # L.update + # L.nil # L.pair + +test_DUP :: TestTree +test_DUP = + -- This is a case where the emulator and the network's implementation diverge *slightly*. + -- + -- * In the emulator, the @DUP@ instruction _always_ creates a new bigmap ID. + -- * In a network, the @DUP@ instruction _usually_ creates a new bigmap ID, + -- except in a very specific situation: when you duplicate a bigmap, save + -- the duplicate in the storage and discard the old bigmap. + -- When this happens, the old bigmap's ID is reused and assigned to the new bigmap. + -- + -- I don't think the fact that the two implementations diverge is a problem per se, + -- because, IMO, users shouldn't rely on bigmap's IDs remaining the same + -- across contract calls anyways. + -- + -- This test is here as a means of documentation. + testGroup "DUP" + [ testScenario "BigMap ID may be reused when old BigMap is discarded" $ scenario do + addr <- originateSimple "contract" [("a", 1)] dupAndDiscardOld + + originalId <- getStorage addr + call addr CallDefault () + dupId <- getStorage addr + + ifEmulation @() + -- In the emulator, the dupped bigmap is always assigned a brand new ID. + (do unBigMapId dupId @/= unBigMapId originalId) + -- In a network, the old ID might be reused. + (do unBigMapId dupId @== unBigMapId originalId) + + , testScenario "A new BigMap ID is generated when the old BigMap is not discarded" $ scenario do + addr <- originateSimple "contract" ([("a", 1)], [("a", 1)]) dupAndKeepBoth + + (id0, _) <- getStorage addr + call addr CallDefault () + (id1, dupId) <- getStorage addr + + -- The original bigmap's ID did not change + unBigMapId id0 @== unBigMapId id1 + -- The dupped bigmap has been assigned a new ID + unBigMapId dupId @/= unBigMapId id1 + ] + where + -- Duplicate an existing bigmap, save it in the storage, and discard the old bigmap. + dupAndDiscardOld :: Contract () (BigMap MText Integer) () + dupAndDiscardOld = L.mkContractWith L.intactCompilationOptions $ + L.cdr + # L.dup + # L.dip L.drop + # L.nil # L.pair + + -- Duplicate an existing bigmap, save both (the old and the new) bigmaps in the storage. + dupAndKeepBoth :: Contract () (BigMap MText Integer, BigMap MText Integer) () + dupAndKeepBoth = L.mkContractWith L.intactCompilationOptions $ + L.cdr + # L.car + # L.stackType @'[ BigMap MText Integer ] + # L.dup + # L.swap + # L.pair + # L.nil # L.pair test_UniqueIDs :: TestTree test_UniqueIDs = diff --git a/test/TestSuite/Cleveland/Tasty.hs b/test/TestSuite/Cleveland/Tasty.hs --- a/test/TestSuite/Cleveland/Tasty.hs +++ b/test/TestSuite/Cleveland/Tasty.hs @@ -1,14 +1,13 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Tasty ( test_Memoize , test_OptionsCombinations ) where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.Options (OptionSet, singleOption) import Test.Tasty.Runners (TreeFold(..), foldTestTree, trivialFold) diff --git a/test/TestSuite/Cleveland/Tasty/Report.hs b/test/TestSuite/Cleveland/Tasty/Report.hs --- a/test/TestSuite/Cleveland/Tasty/Report.hs +++ b/test/TestSuite/Cleveland/Tasty/Report.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Tasty.Report ( test_formatError @@ -8,12 +7,12 @@ ) where import Data.Char (isSpace) -import qualified Data.Text as Text +import Data.Text qualified as Text import Fmt (build, indentF, pretty, unlinesF) import GHC.Stack (SrcLoc(..), fromCallSiteList) import System.FilePath (()) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import Test.Tasty.Options (singleOption) import Test.Tasty.Runners (Result(resultDescription)) diff --git a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs --- a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs +++ b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Tasty.Report.Examples ( reportExamples @@ -16,6 +15,8 @@ + + ---------------------------------------------------------------------------- -- Examples ---------------------------------------------------------------------------- @@ -27,11 +28,11 @@ example1ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ -23 ┃ example1 :: EmulatedT PureM () -24 ┃ example1 = void $ signBytes "" unknownAddr +24 ┃ example1 :: EmulatedT PureM () +25 ┃ example1 = void $ signBytes "" unknownAddr ┃ ^^^^^^^^^^^^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z -25 ┃ +26 ┃ CallStack (from HasCallStack): |] @@ -50,11 +51,11 @@ exampleWithHelperFunction1ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 46 ┃ exampleWithHelperFunction1Helper :: EmulatedT PureM () - 47 ┃ exampleWithHelperFunction1Helper = void $ signBytes "" unknownAddr + 47 ┃ exampleWithHelperFunction1Helper :: EmulatedT PureM () + 48 ┃ exampleWithHelperFunction1Helper = void $ signBytes "" unknownAddr ┃ ^^^^^^^^^^^^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 48 ┃ + 49 ┃ CallStack (from HasCallStack): |] @@ -69,11 +70,11 @@ exampleWithHelperFunction2ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 62 ┃ exampleWithHelperFunction2 :: EmulatedT PureM () - 63 ┃ exampleWithHelperFunction2 = exampleWithHelperFunction2Helper + 63 ┃ exampleWithHelperFunction2 :: EmulatedT PureM () + 64 ┃ exampleWithHelperFunction2 = exampleWithHelperFunction2Helper ┃ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 64 ┃ + 65 ┃ CallStack (from HasCallStack): |] @@ -105,13 +106,13 @@ exampleMultipleLines1ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 99 ┃ exampleMultipleLines1 = - 100 ┃ void ( signBytes - 101 ┃ "" - 102 ┃ unknownAddr ) + 100 ┃ exampleMultipleLines1 = + 101 ┃ void ( signBytes + 102 ┃ "" + 103 ┃ unknownAddr ) ┃ ^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 103 ┃ + 104 ┃ CallStack (from HasCallStack): |] @@ -126,13 +127,13 @@ exampleMultipleLines2ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 120 ┃ exampleMultipleLines2 = - 121 ┃ void ( signBytes - 122 ┃ "" - 123 ┃ unknownAddr ) + 121 ┃ exampleMultipleLines2 = + 122 ┃ void ( signBytes + 123 ┃ "" + 124 ┃ unknownAddr ) ┃ ^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 124 ┃ + 125 ┃ CallStack (from HasCallStack): |] @@ -147,13 +148,13 @@ exampleMultipleLines3ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 141 ┃ exampleMultipleLines3 = - 142 ┃ void ( signBytes - 143 ┃ "" - 144 ┃ unknownAddr ) + 142 ┃ exampleMultipleLines3 = + 143 ┃ void ( signBytes + 144 ┃ "" + 145 ┃ unknownAddr ) ┃ ^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 145 ┃ + 146 ┃ CallStack (from HasCallStack): |] @@ -168,13 +169,13 @@ exampleMultipleLines4ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 162 ┃ exampleMultipleLines4 = - 163 ┃ void ( signBytes - 164 ┃ "" - 165 ┃ unknownAddr ) + 163 ┃ exampleMultipleLines4 = + 164 ┃ void ( signBytes + 165 ┃ "" + 166 ┃ unknownAddr ) ┃ ^^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 166 ┃ + 167 ┃ CallStack (from HasCallStack): |] @@ -189,13 +190,13 @@ exampleMultipleLines5ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 183 ┃ exampleMultipleLines5 = - 184 ┃ void ( signBytes - 185 ┃ "" - 186 ┃ unknownAddr ) + 184 ┃ exampleMultipleLines5 = + 185 ┃ void ( signBytes + 186 ┃ "" + 187 ┃ unknownAddr ) ┃ ^^^^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 187 ┃ + 188 ┃ CallStack (from HasCallStack): |] @@ -210,19 +211,19 @@ exampleMultipleLines6ExpectedErr = [itu| ┏━━ #{reportExamplesPath} ━━━ - 204 ┃ exampleMultipleLines6 = - 205 ┃ void ( signBytes - 206 ┃ "" - 207 ┃ unknownAddr ) + 205 ┃ exampleMultipleLines6 = + 206 ┃ void ( signBytes + 207 ┃ "" + 208 ┃ unknownAddr ) ┃ ^^^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 208 ┃ + 209 ┃ CallStack (from HasCallStack): |] unknownAddr :: Address -unknownAddr = unsafeParseAddress "tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z" +unknownAddr = unsafe $ parseAddress "tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z" reportExamples :: [(String, EmulatedT PureM (), Text)] reportExamples = diff --git a/test/TestSuite/Cleveland/Time.hs b/test/TestSuite/Cleveland/Time.hs --- a/test/TestSuite/Cleveland/Time.hs +++ b/test/TestSuite/Cleveland/Time.hs @@ -1,14 +1,13 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Time ( test_Time ) where -import Data.Time -import Test.Tasty -import Time +import Data.Time (diffUTCTime) +import Test.Tasty (TestTree, testGroup) +import Time (Second, Time) import Morley.Michelson.Runtime.Dummy (dummyNow) import Morley.Tezos.Core as Tezos diff --git a/test/TestSuite/Cleveland/TransferCheck.hs b/test/TestSuite/Cleveland/TransferCheck.hs --- a/test/TestSuite/Cleveland/TransferCheck.hs +++ b/test/TestSuite/Cleveland/TransferCheck.hs @@ -1,16 +1,15 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.TransferCheck ( test_TransferFromContract , test_nonUnitParamToImplicitAccount_fails ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz ((#)) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Value import Morley.Util.Named ((!)) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/UsedFramework.hs b/test/TestSuite/Cleveland/UsedFramework.hs --- a/test/TestSuite/Cleveland/UsedFramework.hs +++ b/test/TestSuite/Cleveland/UsedFramework.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.UsedFramework ( test_usedFramework @@ -14,14 +13,13 @@ test_usedFramework :: TestTree test_usedFramework = testGroup "getRunMode" [ testScenarioOnNetwork "On chain" $ scenario do - getRunMode >>= \case - NetworkMode -> pass - EmulationMode -> failure "Returned wrong mode" + whenEmulation $ failure "Returned wrong mode" - , testScenarioOnEmulator "Emulated" $ scenarioEmulated do - getRunMode >>= \case - EmulationMode -> pass - NetworkMode -> failure "Returned wrong mode" + , testScenarioOnEmulator "Cleveland on emulator" $ scenario do + whenNetwork $ failure "Returned wrong mode" + + , testScenarioOnEmulator "Emulated on emulator" $ scenarioEmulated do + whenNetwork $ failure "Returned wrong mode" ] test_whenEmulation :: TestTree diff --git a/test/TestSuite/Cleveland/Util.hs b/test/TestSuite/Cleveland/Util.hs --- a/test/TestSuite/Cleveland/Util.hs +++ b/test/TestSuite/Cleveland/Util.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.Util ( test_Time diff --git a/test/TestSuite/Cleveland/VotingPower.hs b/test/TestSuite/Cleveland/VotingPower.hs --- a/test/TestSuite/Cleveland/VotingPower.hs +++ b/test/TestSuite/Cleveland/VotingPower.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module testing voting power instructions and their support from -- cleveland. @@ -8,7 +7,7 @@ ( test_VotingPowers ) where -import Test.Tasty +import Test.Tasty (TestTree) import Lorentz.Value import Morley.Tezos.Crypto @@ -21,7 +20,7 @@ <- originateSimple "vp contract" 0 =<< importContract @KeyHash @Natural @() ("../../contracts/voting_power.tz") - let keyHash = unsafeParseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" + let keyHash = unsafe $ parseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" call contract CallDefault keyHash getStorage contract @@== 0 @@ -31,8 +30,8 @@ =<< importContract @KeyHash @(Natural, Natural) @() ("../../contracts/voting_powers.tz") comment "Setting custom voting powers to access them later" - let keyHash = unsafeParseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" - let keyHash2 = unsafeParseKeyHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs" + let keyHash = unsafe $ parseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" + let keyHash2 = unsafe $ parseKeyHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs" setVotingPowers (mkVotingPowers [(keyHash, 123), (keyHash2, 57)]) call contract CallDefault keyHash diff --git a/test/TestSuite/Cleveland/WithMoneybag.hs b/test/TestSuite/Cleveland/WithMoneybag.hs --- a/test/TestSuite/Cleveland/WithMoneybag.hs +++ b/test/TestSuite/Cleveland/WithMoneybag.hs @@ -1,12 +1,11 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.WithMoneybag ( test_withMoneybag ) where -import Test.Tasty +import Test.Tasty (TestTree) import Test.Cleveland diff --git a/test/TestSuite/Cleveland/WithSender.hs b/test/TestSuite/Cleveland/WithSender.hs --- a/test/TestSuite/Cleveland/WithSender.hs +++ b/test/TestSuite/Cleveland/WithSender.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module TestSuite.Cleveland.WithSender ( test_Money_are_spent_from_sender , test_Sender_in_contract_call_is_updated ) where -import Test.Tasty +import Test.Tasty (TestTree) import Test.Cleveland import TestSuite.Util (idContract, saveSender) diff --git a/test/TestSuite/Util.hs b/test/TestSuite/Util.hs --- a/test/TestSuite/Util.hs +++ b/test/TestSuite/Util.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- Utility functions used in the @cleveland:test:cleveland-test@ test suite. module TestSuite.Util @@ -22,7 +21,7 @@ import Lorentz import Data.List (isInfixOf) -import Fmt (Buildable, GenericBuildable(..), build, indentF, unlinesF) +import Fmt (Buildable, GenericBuildable(..), build, indentF, pretty, unlinesF) import Hedgehog (Property) import System.Environment (lookupEnv, setEnv, unsetEnv) import Test.Tasty.HUnit (Assertion, assertFailure, testCase) @@ -106,7 +105,7 @@ Failure reason -> assertFailure $ toString $ unlines [ "Expected Tasty test to fail because the cleveland test failed, but failed because:" - , show reason + , pretty reason ] Success -> assertFailure "Expected Tasty test to fail, but it succeeded" @@ -115,12 +114,12 @@ -- the given string. shouldFailWithMessage :: forall any caps m. - (HasCallStack, MonadCleveland caps m, Show any) + (HasCallStack, MonadCleveland caps m, Buildable any) => String -> m any -> m () shouldFailWithMessage expectedMessage action = do attempt @SomeException action >>= \case Right x -> - failure $ "Expected action to fail, but it succeeded with: " <> show x + failure $ "Expected action to fail, but it succeeded with: " <> pretty x Left ex -> unless (expectedMessage `isInfixOf` displayException ex) $ failure $ unlinesF @@ -136,18 +135,14 @@ ---------------------------------------------------------------------------- -- | Simple contract that does nothing when called. -idContractData :: (NiceParameterFull cp, NiceStorage st) => ContractData cp st () -idContractData = defaultContractData $ +idContract :: (NiceParameterFull cp, NiceStorageFull st) => Contract cp st () +idContract = defaultContract $ cdr # nil @Operation # pair --- | Simple contract that does nothing when called. -idContract :: (NiceParameterFull cp, NiceStorage st) => Contract cp st () -idContract = compileLorentzContract idContractData - -- | Simple contract that takes a parameter and saves it in its storage. -saveInStorageContract :: (NiceParameterFull st, NiceStorage st) => Contract st st () +saveInStorageContract :: (NiceParameterFull st, NiceStorageFull st) => Contract st st () saveInStorageContract = defaultContract $ car # nil @Operation # @@ -170,5 +165,5 @@ , ssField2 :: Natural } deriving stock (Generic, Show, Eq) - deriving anyclass (IsoValue, HasAnnotation) + deriving anyclass (IsoValue) deriving Buildable via GenericBuildable BigMapInStorage