diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,18 @@ +0.1.2 +===== +* [!1050](https://gitlab.com/morley-framework/morley/-/merge_requests/1050) + Modify resolveAddress to accept AliasHints +* [!1039](https://gitlab.com/morley-framework/morley/-/merge_requests/1039) + Parameterize generators with a Range + + `minTimestamp`, `maxTimestamp` and `midTimestamp` are moved to `Hedgehog.Range.Tezos.Core.Timestamp`. +* [!1017](https://gitlab.com/morley-framework/morley/-/merge_requests/1017) + Resolve some TODOs and link TODOs without issue id to the corresponding gitlab tickets. +* [!1082](https://gitlab.com/morley-framework/morley/-/merge_requests/1082) + Fix/drop/comment noncanonical Show instances + 0.1.1 ===== * [!1113](https://gitlab.com/morley-framework/morley/-/merge_requests/1113) 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.1 +version: 0.1.2 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 @@ -45,6 +45,9 @@ Hedgehog.Gen.Tezos.Crypto.P256 Hedgehog.Gen.Tezos.Crypto.Secp256k1 Hedgehog.Gen.Tezos.Crypto.Timelock + Hedgehog.Range.Defaults + Hedgehog.Range.Defaults.Orphans + Hedgehog.Range.Tezos.Core.Timestamp Lorentz.Test.DupableScan Test.Cleveland Test.Cleveland.Doc @@ -225,12 +228,11 @@ TestSuite.Cleveland.WithMoneybag TestSuite.Cleveland.WithSender TestSuite.Util + TestSuite.Util.Contracts Tree - Test.Util.Contracts Paths_cleveland hs-source-dirs: test - test-common default-extensions: AllowAmbiguousTypes ApplicativeDo @@ -287,7 +289,6 @@ build-depends: base-noprelude >=4.7 && <5 , cleveland - , directory , either , filepath , fmt @@ -307,451 +308,4 @@ , temporary , text , time - default-language: Haskell2010 - -test-suite lorentz-test - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Test.Doc - Test.DocTest - Test.Lorentz.Base - Test.Lorentz.BLS12381 - Test.Lorentz.Case - Test.Lorentz.Conditionals - Test.Lorentz.ContractRegistry - Test.Lorentz.CustomArith - 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 - Test.Lorentz.StoreClass.SetSubmap - Test.Lorentz.StoreClass.StorageEntrypoints - Test.Lorentz.StoreClass.SubmapZoom - Test.Lorentz.Tickets - Test.Lorentz.Tickets.Contracts - Test.Lorentz.Tickets.Helpers - Test.Lorentz.Timelock - Test.Lorentz.UParam - Test.Lorentz.Views - Test.Lorentz.ViewsImport - Test.Tasty.TypeSpec - Test.Util.Annotation - Test.Util.TypeSpec - Tree - Test.Util.Contracts - Paths_cleveland - hs-source-dirs: - lorentz-test - test-common - default-extensions: - AllowAmbiguousTypes - ApplicativeDo - BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - EmptyCase - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NegativeLiterals - NumDecimals - NumericUnderscores - OverloadedLabels - OverloadedStrings - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - RankNTypes - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - StrictData - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - UndecidableInstances - UndecidableSuperClasses - ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m" - build-tool-depends: - tasty-discover:tasty-discover - build-depends: - HUnit - , base-noprelude >=4.7 && <5 - , bimap - , bytestring - , cleveland - , constraints - , containers - , directory - , filepath - , first-class-families - , fmt - , hedgehog >=1.0.3 - , lens - , lorentz - , morley - , morley-prelude - , singletons - , spoon - , tasty - , tasty-hedgehog - , tasty-hunit-compat - , text - , type-spec - , unordered-containers - default-language: Haskell2010 - -test-suite morley-client-test - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Test.Fee - Test.RPCKeyRevealing - Tree - Test.Util.Contracts - Paths_cleveland - hs-source-dirs: - morley-client-test - test-common - default-extensions: - AllowAmbiguousTypes - ApplicativeDo - BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - EmptyCase - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NegativeLiterals - NumDecimals - NumericUnderscores - OverloadedLabels - OverloadedStrings - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - RankNTypes - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - StrictData - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - UndecidableInstances - UndecidableSuperClasses - ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m" - build-tool-depends: - tasty-discover:tasty-discover - build-depends: - HUnit - , base-noprelude >=4.7 && <5 - , cleveland - , cryptonite - , directory - , filepath - , morley - , morley-client - , morley-prelude - , tasty - , tasty-hunit-compat - default-language: Haskell2010 - -test-suite morley-test - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Test.Analyzer - Test.AsRPC - Test.Doc.Position - Test.Entrypoints - Test.Ext - Test.Import - Test.Integrational - Test.Interpreter - Test.Interpreter.Annotations - Test.Interpreter.Apply - Test.Interpreter.Auction - Test.Interpreter.Balance - Test.Interpreter.CallSelf - Test.Interpreter.CallSelfAddress - Test.Interpreter.ComparableSet - Test.Interpreter.Compare - Test.Interpreter.ComparePairs - Test.Interpreter.Conditionals - Test.Interpreter.ContractOp - Test.Interpreter.CreateAndReverseOps - Test.Interpreter.CreateAndTransfer - Test.Interpreter.EnvironmentSpec - Test.Interpreter.Print - Test.Interpreter.Reference - Test.Interpreter.SetDelegate - Test.Interpreter.StackRef - Test.Interpreter.StringCaller - Test.Interpreter.TransferAndCreate - Test.Interpreter.Views - Test.Macro - Test.Michelson.Parser.Value - Test.Michelson.Runtime - Test.Michelson.Show - Test.Michelson.Text - Test.Michelson.Typed.AnnotatedValue - Test.Michelson.Typed.Convert - Test.Michelson.Typed.Util - Test.Michelson.Typed.Value - Test.Morley.Expression - Test.OpSize - Test.Optimizer - Test.Parser - Test.Preprocess - Test.Printer.Michelson - Test.Serialization.Aeson - Test.Serialization.Typed.Michelson - Test.Serialization.Untyped.Michelson - Test.Serialization.Util - Test.Tezos.Address - Test.Tezos.Core - Test.Tezos.Crypto - Test.Tezos.Crypto.BLS12381 - Test.Tezos.Crypto.Hash - Test.Tezos.Crypto.Timelock - Test.Typeable - Test.Typecheck - Test.Typecheck.Annotation - Test.Untyped.Instr - Test.Util.Hedgehog - Test.Util.HUnit - Test.Util.Parser - Test.Util.TH - Test.ValConversion - Test.Views - Tree - Test.Util.Contracts - Paths_cleveland - hs-source-dirs: - morley-test - test-common - default-extensions: - AllowAmbiguousTypes - ApplicativeDo - BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - EmptyCase - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NegativeLiterals - NumDecimals - NumericUnderscores - OverloadedLabels - OverloadedStrings - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - RankNTypes - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - StrictData - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - UndecidableInstances - UndecidableSuperClasses - ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m" - build-tool-depends: - tasty-discover:tasty-discover - build-depends: - HUnit - , aeson - , aeson-pretty - , aeson-qq - , base-noprelude >=4.7 && <5 - , bytestring - , cleveland - , constraints - , containers - , data-default - , directory - , filepath - , fmt - , hedgehog >=1.0.3 - , hex-text - , hspec - , hspec-expectations - , lens - , lorentz - , megaparsec >=7.0.0 - , morley - , morley-client - , morley-prelude - , mtl - , named - , silently - , singletons - , syb - , tasty - , tasty-hedgehog - , tasty-hspec - , tasty-hunit-compat - , template-haskell - , text - , unordered-containers - , vinyl - , with-utf8 - default-language: Haskell2010 - -benchmark morley-bench - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_cleveland - hs-source-dirs: - morley-bench - default-extensions: - AllowAmbiguousTypes - ApplicativeDo - BangPatterns - BlockArguments - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DerivingStrategies - DerivingVia - EmptyCase - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NegativeLiterals - NumDecimals - NumericUnderscores - OverloadedLabels - OverloadedStrings - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - RankNTypes - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - StrictData - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - UndecidableInstances - UndecidableSuperClasses - ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages - build-depends: - base-noprelude >=4.7 && <5 - , cleveland - , data-default - , gauge - , megaparsec >=7.0.0 - , morley - , morley-prelude - , with-utf8 default-language: Haskell2010 diff --git a/lorentz-test/Main.hs b/lorentz-test/Main.hs deleted file mode 100644 --- a/lorentz-test/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Main - ( main - ) where - -import Test.Cleveland.Ingredients (ourIngredients) -import Test.Cleveland.Tasty (clevelandMainWithIngredients) - -import Tree (tests) - -main :: IO () -main = tests >>= clevelandMainWithIngredients ourIngredients diff --git a/lorentz-test/Test/Doc.hs b/lorentz-test/Test/Doc.hs deleted file mode 100644 --- a/lorentz-test/Test/Doc.hs +++ /dev/null @@ -1,164 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on automatic documentation generation. - -module Test.Doc - ( test_General_doc_scan - , test_Dependencies_loops - , test_Cutting_all_except_doc - , test_fakeCoerce - ) where - -import Data.Set qualified as Set -import Data.Text.Lazy.Builder (toLazyText) -import Fmt (build) -import Hedgehog (evalNF, property) -import Test.HUnit (assertBool, assertFailure, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.Hedgehog (testProperty) - -import Lorentz ((#)) -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 - --- General tests on contract doc scan ----------------------------------------------------------------------------- - -newtype MyType = MyType Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyType where - typeDocMdDescription = "" - -data MyGroup = MyGroup Text SubDoc - -instance DocItem MyGroup where - docItemPos = 91232 - docItemSectionName = Nothing - docItemToMarkdown lvl (MyGroup name subDoc) = - build name <> subDocToMarkdown lvl subDoc - -test_General_doc_scan :: [TestTree] -test_General_doc_scan = - [ testCase "Type declaration is found" $ - let contract = L.doc $ DType (Proxy @MyType) - doc = buildDocTest contract - in case lookupDocBlockSection @DType $ cdDefinitions doc of - Just (toList -> ds) -> - sort ds @?= sort [DType (Proxy @MyType), DType (Proxy @Integer)] - Nothing -> - assertFailure "DTypes not found" - - , testCase "Dependencies of polymorphic types are found" $ - -- There once was a bug which caused, in the following scenario, - -- 'Integer' type to be found while 'Natural' to be not, doc items - -- discovery thought that ":!" has already been traversed and didn't - -- pick its dependencies the second time. - let contract = L.doc $ L.mkDEntrypointArgSimple @("a" :! Integer, "b" :! Natural) - doc = buildDocTest contract - defs = cdDefinitionsSet doc - in do - assertBool "'Integer' declaration is present" $ - Set.member (SomeDocDefinitionItem $ DType (Proxy @Integer)) defs - assertBool "'Natural' declaration is present" $ - Set.member (SomeDocDefinitionItem $ DType (Proxy @Natural)) defs - - , testCase "Doc group is handled correctly" $ - let contract = L.docGroup (MyGroup "a") $ - L.doc $ DDescription "a" - doc = buildDocTest contract - contents = cdContents doc - in case lookupDocBlockSection contents of - Just (MyGroup "a" (SubDoc subcontents) :| []) -> - case lookupDocBlockSection subcontents of - Just (DDescription "a" :| []) -> - pass - _ -> 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 ----------------------------------------------------------------------------- - --- | Type, documentation for which somehow depends on itself. -newtype MyLoopedType = MyLoopedType Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyLoopedType where - typeDocDependencies _ = [dTypeDep @MyLoopedType] - typeDocMdDescription = "" - -newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -newtype MyMutuallyDependentType2 = MyMutuallyDependentType2 Integer - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyMutuallyDependentType1 where - typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType2] - typeDocMdDescription = "" - -instance TypeHasDoc MyMutuallyDependentType2 where - typeDocDependencies _ = [dTypeDep @MyMutuallyDependentType1] - typeDocMdDescription = "" - -test_Dependencies_loops :: [TestTree] -test_Dependencies_loops = - [ testProperty "Type depending on itself" $ property $ - let contract = L.doc $ DType (Proxy @MyLoopedType) - in void . evalNF $ buildMarkdownDocTest contract - , testProperty "Mutually dependent types" $ property $ - let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1) - in void . evalNF $ buildMarkdownDocTest contract - ] - --- Functions semantics ----------------------------------------------------------------------------- - -test_Cutting_all_except_doc :: [TestTree] -test_Cutting_all_except_doc = - [ testCase "Cleaning simple code" $ - let contract = - L.doc (DDescription "a") # - L.push True # - L.if_ (L.docGroup "aaa" $ L.doc $ DDescription "b") (L.sender # L.drop) - :: '[] L.:-> '[] - cutContract = - L.doc (DDescription "a") # - L.docGroup "aaa" (L.doc $ DDescription "b") - in buildMarkdownDocTest (L.cutLorentzNonDoc contract) - @?= - buildMarkdownDocTest cutContract - - , testCase "DocGroup is handled correctly" $ - let contract = - L.docGroup (MyGroup "b") $ - L.doc (DDescription "a") # L.nop - cutContract = - L.docGroup (MyGroup "b") $ - L.doc (DDescription "a") - in buildMarkdownDocTest (L.cutLorentzNonDoc contract) - @?= - buildMarkdownDocTest cutContract - ] - -test_fakeCoerce :: [TestTree] -test_fakeCoerce = - [ testCase "Does not truncate the following documentation" $ - let contract = L.doc (DDescription "a") :: '[] L.:-> '[] - in buildMarkdownDocTest (L.fakeCoerce # contract) - @?= - buildMarkdownDocTest contract - ] diff --git a/lorentz-test/Test/DocTest.hs b/lorentz-test/Test/DocTest.hs deleted file mode 100644 --- a/lorentz-test/Test/DocTest.hs +++ /dev/null @@ -1,70 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on doc test framework. -module Test.DocTest - ( test_Predicates_work - , test_Exclusion_works - ) where - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz ((#), (/->)) -import Lorentz qualified as L -import Lorentz.Entrypoints.Doc -import Morley.Michelson.Doc -import Test.Cleveland.Doc - --- A bad contract because it uses 'caseT' instead of 'entryCase' -contract1 :: L.ContractCode (Either Integer Natural) Integer -contract1 = L.car # L.caseT - ( #cLeft /-> - L.doc (DDescription "Handles left") # - L.nop - , #cRight /-> - L.doc (DDescription "Handles right") # - L.int - ) # L.nil # L.pair - -contract2 :: L.ContractCode (Either Integer Natural) Integer -contract2 = L.car # L.entryCase (Proxy @PlainEntrypointsKind) - ( #cLeft /-> L.nop - , #cRight /-> L.int - ) # L.nil # L.pair - -test_Predicates_work :: [TestTree] -test_Predicates_work = - [ testCase "Name at top absence is detected" $ - expectDocTestFailure testContractNameAtTop contract1 - , testCase "Multiple adjacent descriptions are detected" $ - expectDocTestFailure testNoAdjacentDescriptions contract1 - , testCase "Absence of parameter description is detected" $ - expectDocTestFailure testDeclaresParameter contract1 - , testCase "Absence of entrypoint description is detected" $ - expectDocTestFailure testEachEntrypointIsDescribed contract2 - ] - --- Normally doc test suites should not be declared with 'HasCallStack', but --- this may potentially break 'excludeDocTests' so we try this here. -testDummyWithCallStack :: HasCallStack => DocTest -testDummyWithCallStack = mkDocTest "dummy" $ \_ -> pass - -test_Exclusion_works :: [TestTree] -test_Exclusion_works = - [ testCase "Exclusion removes only expected things" $ - [ testContractNameAtTop - , testDocNotEmpty - , testNoAdjacentDescriptions - , testDummyWithCallStack - ] - `excludeDocTests` - [ testDocNotEmpty - , testDummyWithCallStack - ] - @?= - [ testContractNameAtTop - , testNoAdjacentDescriptions - ] - ] diff --git a/lorentz-test/Test/Lorentz/BLS12381.hs b/lorentz-test/Test/Lorentz/BLS12381.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/BLS12381.hs +++ /dev/null @@ -1,28 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - --- | Tests on BLS12381 primitives accessibility. -module Test.Lorentz.BLS12381 - ( unit_Contract1 - ) where - -import Lorentz - -import Test.HUnit (Assertion, (@?=)) - -import Morley.Tezos.Crypto.BLS12381 qualified as BLS - -pairingCheckCode :: Lambda (Bls12381G1, Bls12381G2) Bool -pairingCheckCode = do - dip nil; cons - push @Natural 1; push @Bls12381Fr 1; mul; push BLS.g2One; neg; mul - push BLS.g1One; pair; cons - pairingCheck - -unit_Contract1 :: Assertion -unit_Contract1 = - pairingCheckCode -$ (BLS.g1One, BLS.g2One) - @?= True diff --git a/lorentz-test/Test/Lorentz/Base.hs b/lorentz-test/Test/Lorentz/Base.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Base.hs +++ /dev/null @@ -1,31 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for basic Lorentz functionality. - -module Test.Lorentz.Base - ( unit_parseLorentzValue - ) where - -import Test.HUnit (Assertion, (@?=)) - -import Lorentz.Base (parseLorentzValue) -import Morley.Michelson.Parser (codeSrc) -import Morley.Michelson.Typed (IsoValue) - --- Sum type. -data S - = S1 Bool - | S2 - | S3 Integer - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - --- Product type. -type P = (Bool, Integer, S, S) - -unit_parseLorentzValue :: Assertion -unit_parseLorentzValue = do - parseLorentzValue codeSrc "Left True" @?= Right (S1 True) - parseLorentzValue @P codeSrc "Pair (Pair False 20) (Pair (Right (Left Unit)) (Right (Right 15)))" @?= - Right (False, 20, S2, S3 15) diff --git a/lorentz-test/Test/Lorentz/Case.hs b/lorentz-test/Test/Lorentz/Case.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Case.hs +++ /dev/null @@ -1,65 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on mere @case@ in Lorentz (without entrypoints). -module Test.Lorentz.Case - ( test_caseT - ) where - - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz ((#), (/->)) -import Lorentz qualified as L -import Lorentz.Run.Simple -import Morley.Michelson.Typed (IsoValue) - -data Data0 - deriving stock (Generic) - deriving anyclass (IsoValue) - -data Data1 = Data1 Natural - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - -data Data1N = Data1N - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - -data Data3 - = Data3Ctor1 Natural - | Data3Ctor2 Integer - | Data3Ctor3 - deriving stock (Generic, Eq, Show) - deriving anyclass (IsoValue) - -test_caseT :: [TestTree] -test_caseT = - [ testCase "No constructors" $ - evaluateNF_ . L.compileLorentz $ L.caseT @Data0 () - - , testCase "One constructor" $ - -- 'stackType' is necessary because '&-' may accept multiple stack elements - -- as input, and here it is not possible to infer how much we provide. - -- That's a point for not making '&-' such complex. - Data1 5 &- L.stackType @'[_] # L.caseT @Data1 - ( #cData1 /-> L.nop - ) - @?= 5 - - , testCase "One nullary constructor" $ - Data1N &- L.stackType @'[_] # L.caseT @Data1N - ( #cData1N /-> L.unit - ) - @?= () - - , testCase "Several constructors" $ - L.caseT @Data3 - ( #cData3Ctor1 /-> L.int - , #cData3Ctor2 /-> L.nop - , #cData3Ctor3 /-> L.push 0 - ) <-$> [Data3Ctor1 5, Data3Ctor2 -5, Data3Ctor3] - @?= [5, -5, 0] - ] diff --git a/lorentz-test/Test/Lorentz/Conditionals.hs b/lorentz-test/Test/Lorentz/Conditionals.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Conditionals.hs +++ /dev/null @@ -1,64 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - --- | Tests (and examples) on Lorentz' @if .. then .. else ..@. -module Test.Lorentz.Conditionals - ( test_Named - , test_Not - , test_Complex - ) where - -import Lorentz - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - - -test_Named :: [TestTree] -test_Named = - [ testCase "Named compare works good" $ - myContract -$? (5 :: Natural) - @?= Right True - ] - where - myContract = do - toNamed #x - push @Natural 3; toNamed #y - if #y >=. #x - then push False - else push True - -test_Not :: [TestTree] -test_Not = - [ testCase "Not Holds" $ - False &- (if Not Holds then push [mt|ok|] else push [mt|bad|]) - @?= [mt|ok|] - - , testCase "Not IsZero" $ - (5 :: Integer) &- (if Not IsZero then push [mt|ok|] else push [mt|bad|]) - @?= [mt|ok|] - - , testCase "Not IsNone" $ - Just [mt|x|] &- (if Not IsNone then nop else push [mt|bad|]) - @?= [mt|x|] - - ] - -test_Complex :: [TestTree] -test_Complex = - [ testCase "Can evaluate complex conditions" $ - myContract -$? (5 :: Natural) - @?= Right True - ] - where - myContract :: Lambda Natural Bool - myContract = do - toNamed #x - dup - if fromNamed #x |>| push 3 |&| fromNamed #x |<| push 7 - then push True - else push False diff --git a/lorentz-test/Test/Lorentz/ContractRegistry.hs b/lorentz-test/Test/Lorentz/ContractRegistry.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/ContractRegistry.hs +++ /dev/null @@ -1,68 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Tests on contract registry. -module Test.Lorentz.ContractRegistry - ( unit_contractRegistryCommands - ) where - -import Lorentz -import Prelude hiding (drop) - -import Data.Map qualified as Map -import System.Directory (removeFile) -import System.Directory.Internal.Prelude (isDoesNotExistError) -import Test.HUnit (Assertion, assertFailure) - -import Lorentz.ContractRegistry - -instance Exception Text - -sampleContract :: Contract () () () -sampleContract = defaultContract $ - drop # unit # nil # pair - -sampleContractInfo :: ContractInfo -sampleContractInfo = ContractInfo - { ciContract = sampleContract - , ciIsDocumented = False - , ciStorageParser = Just (pure ()) - , ciStorageNotes = Nothing - } - -singleContractReg :: ContractRegistry -singleContractReg = ContractRegistry $ Map.fromList - [ "Sample" ?:: sampleContractInfo - ] - -multiContractReg :: ContractRegistry -multiContractReg = ContractRegistry $ Map.fromList - [ "Sample" ?:: sampleContractInfo - , "Sample2" ?:: sampleContractInfo - ] - --- | Remove a file, checking that it is present. If not, an exception is raised. -checkAndRemoveFile :: HasCallStack => FilePath -> Assertion -checkAndRemoveFile file = - removeFile file `catch` \e -> - if isDoesNotExistError e - then assertFailure $ "File \"" <> file <> "\" was not created" - else throwM e - -unit_contractRegistryCommands :: Assertion -unit_contractRegistryCommands = do - - runContractRegistry singleContractReg (Print Nothing Nothing False False) - checkAndRemoveFile "Sample.tz" - - runContractRegistry multiContractReg (Print (Just "Sample2") Nothing False False) - checkAndRemoveFile "Sample2.tz" - - -- Fail due to not specifying the name with a contract registry that contains multiple contracts. - e <- try $ runContractRegistry multiContractReg (Print Nothing Nothing False False) - case e of - Right _ -> throwM ("Expect the test to fail." :: Text) - Left (_ :: SomeException) -> pure () diff --git a/lorentz-test/Test/Lorentz/CustomArith.hs b/lorentz-test/Test/Lorentz/CustomArith.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/CustomArith.hs +++ /dev/null @@ -1,324 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- 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 #-} - --- | Tests for custom arithmetic datatypes, added to Lorentz -module Test.Lorentz.CustomArith - ( test_fixedArith - , test_NFixedArith - ) where - -import Prelude hiding (div) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Lorentz - - -test_fixedArith :: TestTree -test_fixedArith = - testGroup "Arithmetic operations on Fixed values" - [ testGroup "Arithmetics" - [ testGroup "Decimal base" - [ testCase "Fixed add" do - add -$ initialStorageDec - @?= (2.2 :: Fixed (DecBase 3)) - , testCase "Fixed sub" do - sub -$ initialStorageDec - @?= (0 :: Fixed (DecBase 3)) - , testCase "Fixed mul" do - mul -$ initialStorageDec - @?= (1.21 :: Fixed (DecBase 6)) - , testCase "Fixed ediv 1" do - ediv -$ (123.456 :: Fixed (DecBase 3), 100 :: Integer) - @?= Just (1, 23.456 :: (NFixed (DecBase 3))) - , testCase "Fixed ediv 2" do - ediv -$ (2 :: Fixed (DecBase 3), 100 :: Integer) - @?= Just (0, 2 :: (NFixed (DecBase 3))) - ] - , testGroup "Binary base" - [ testCase "Fixed add" do - add -$ initialStorageBin - @?= (2.2 :: Fixed (BinBase 1)) - , testCase "Fixed sub" do - sub -$ initialStorageBin - @?= (0 :: Fixed (BinBase 1)) - , testCase "Fixed mul" do - mul -$ initialStorageBin - @?= (1.21 :: Fixed (BinBase 2)) - ] - ] - , testGroup "Rounding" - [ testGroup "Rounding with decimal base" - [ testCase "Round up Fixed with decimal base 1" do - round_ -$ (1.23456 :: (Fixed (DecBase 6))) - @?= (1.235 :: Fixed (DecBase 3)) - , testCase "Round up Fixed with decimal base 2" do - round_ -$ (1.23446 :: (Fixed (DecBase 6))) - @?= (1.234 :: Fixed (DecBase 3)) - , testCase "Round up Fixed with decimal base 3" do - round_ -$ (0.177 :: (Fixed (DecBase 3))) - @?= (0.18 :: Fixed (DecBase 2)) - , testCase "Round up Fixed with decimal base 4" do - round_ -$ (0.173 :: (Fixed (DecBase 3))) - @?= (0.17 :: Fixed (DecBase 2)) - , testCase "Round up Fixed with decimal base 5" do - round_ -$ (1.230 :: (Fixed (DecBase 3))) - @?= (1.23 :: Fixed (DecBase 2)) - , testCase "Ceil 1" do - ceil_ -$ (0.177 :: (Fixed (DecBase 3))) - @?= (0.18 :: Fixed (DecBase 2)) - , testCase "Ceil 2" do - ceil_ -$ (0.173 :: (Fixed (DecBase 3))) - @?= (0.18 :: Fixed (DecBase 2)) - , testCase "Ceil 3" do - ceil_ -$ (1.230 :: (Fixed (DecBase 3))) - @?= (1.23 :: Fixed (DecBase 2)) - , testCase "Floor 1" do - floor_ -$ (0.177 :: (Fixed (DecBase 3))) - @?= (0.17 :: Fixed (DecBase 2)) - , testCase "Floor 2" do - floor_ -$ (0.173 :: (Fixed (DecBase 3))) - @?= (0.17 :: Fixed (DecBase 2)) - , testCase "Floor 3" do - floor_ -$ (1.230 :: (Fixed (DecBase 3))) - @?= (1.23 :: Fixed (DecBase 2)) - , testCase "Round down" do - round_ -$ (1.234 :: Fixed (DecBase 3)) - @?= (1.23400 :: (Fixed (DecBase 6))) - ] - , testGroup "Rounding with Binary Base" - [ testCase "Round up Fixed with binary base 1" do - round_ -$ (0x1.23456 :: (Fixed (BinBase 6))) - @?= (0x1.235 :: Fixed (BinBase 3)) - , testCase "Round up Fixed with binary base 2" do - round_ -$ (0x1.23446 :: (Fixed (BinBase 6))) - @?= (0x1.234 :: Fixed (BinBase 3)) - , testCase "Round up Fixed with binary base 3" do - round_ -$ (0x0.177 :: (Fixed (BinBase 3))) - @?= (0x0.18 :: Fixed (BinBase 2)) - , testCase "Round up Fixed with binary base 4" do - round_ -$ (0x0.173 :: (Fixed (BinBase 3))) - @?= (0x0.17 :: Fixed (BinBase 2)) - , testCase "Round up Fixed with binary base 5" do - round_ -$ (0x1.230 :: (Fixed (BinBase 3))) - @?= (0x1.23 :: Fixed (BinBase 2)) - , testCase "Ceil 1" do - ceil_ -$ (0x0.177 :: (Fixed (BinBase 3))) - @?= (0x0.18 :: Fixed (BinBase 2)) - , testCase "Ceil 2" do - ceil_ -$ (0x0.173 :: (Fixed (BinBase 3))) - @?= (0x0.18 :: Fixed (BinBase 2)) - , testCase "Ceil 3" do - ceil_ -$ (0x1.230 :: (Fixed (BinBase 12))) - @?= (0x1.23 :: Fixed (BinBase 8 - - )) - , testCase "Floor 1" do - floor_ -$ (0x0.177 :: (Fixed (BinBase 3))) - @?= (0x0.17 :: Fixed (BinBase 2)) - , testCase "Floor 2" do - floor_ -$ (0x0.173 :: (Fixed (BinBase 3))) - @?= (0x0.17 :: Fixed (BinBase 2)) - , testCase "Floor 3" do - floor_ -$ (0x1.230 :: (Fixed (BinBase 3))) - @?= (0x1.23 :: Fixed (BinBase 2)) - ] - , testGroup "Casts" - [ testCase "Cast to Integer" do - fromFixed @(Fixed (DecBase 6)) -$ (1.23456 :: (Fixed (DecBase 6))) - @?= 1 - , testCase "Cast Integer to Fixed" do - toFixed @(Fixed (DecBase 6)) -$ (123456 :: Integer) - @?= (123456 :: (Fixed (DecBase 6))) - , testCase "Cast to Integer (Binary base)" do - fromFixed @(Fixed (BinBase 6)) -$ (1.23456 :: (Fixed (BinBase 6))) - @?= 1 - , testCase "Cast Integer to Fixed (Binary base)" do - toFixed @(Fixed (BinBase 6)) -$ (123456 :: Integer) - @?= (123456.00 :: (Fixed (BinBase 6))) - ] - ] - , testGroup "Division" - [ testCase "Divide big Fixed(Dec) to small Fixed(Dec)" do - div @(Maybe (Fixed (DecBase 8))) -$ (625.123 :: Fixed (DecBase 3), 123.23 :: Fixed (DecBase 2)) - @?= Just (5.07281506 :: Fixed (DecBase 8)) - , testCase "Divide small Fixed(Dec) to big Fixed(Dec)" do - div @(Maybe (Fixed (DecBase 8))) -$ (123.23 :: Fixed (DecBase 3), 625.123 :: Fixed (DecBase 2)) - @?= Just (0.19713015 :: Fixed (DecBase 8)) - , testCase "Divide big Fixed(Bin) to small Fixed(Bin)" do - div @(Maybe (Fixed (BinBase 8))) -$ (625.123 :: Fixed (BinBase 3), 123.23 :: Fixed (BinBase 2)) - @?= (Just (5.079 :: Fixed (BinBase 8))) - , testCase "Divide small Fixed(Bin) to big Fixed(Bin)" do - div @(Maybe (Fixed (BinBase 8))) -$ (123.23 :: Fixed (BinBase 3), 625.123 :: Fixed (BinBase 2)) - @?= (Just (0.19713015 :: Fixed (BinBase 8))) - , testCase "Divide by zero" do - div @(Maybe (Fixed (BinBase 8))) -$ (123.23 :: Fixed (BinBase 3), 0 :: Fixed (BinBase 2)) - @?= (Nothing) - ] - ] - where - initialStorageDec = - (1.1 :: Fixed (DecBase 3), 1.1 :: Fixed (DecBase 3)) - - initialStorageBin = - (1.1 :: Fixed (BinBase 1), 1.1 :: Fixed (BinBase 1)) - -test_NFixedArith :: TestTree -test_NFixedArith = - testGroup "Arithmetic operations on NFixed values" - [ testGroup "NFixed to Fixed" - [ testCase "Cast NFixed to Fixed 1" do - castNFixedToFixed -$ (1.23456 :: NFixed (DecBase 6)) - @?= (1.23456 :: Fixed (DecBase 6)) - , testCase "Cast NFixed to Fixed 2" do - castNFixedToFixed -$ (0 :: NFixed (DecBase 6)) - @?= (0 :: Fixed (DecBase 6)) - , testCase "Cast NFixed to Fixed 3" do - castNFixedToFixed -$ (0.12 :: NFixed (DecBase 2)) - @?= (0.12 :: Fixed (DecBase 2)) - ] - , testGroup "Fixed to NFixed" - [ testCase "Cast Fixed to NFixed 1" do - castFixedToNFixed -$ (1.23456 :: Fixed (DecBase 6)) - @?= Just (1.23456 :: NFixed (DecBase 6)) - , testCase "Cast Fixed to NFixed 2" do - castFixedToNFixed -$ (0 :: Fixed (DecBase 6)) - @?= Just (0 :: NFixed (DecBase 6)) - , testCase "Cast Fixed to NFixed 3" do - castFixedToNFixed -$ (0.12 :: Fixed (DecBase 2)) - @?= Just (0.12 :: NFixed (DecBase 2)) - ] - , testGroup "Decimal base" - [ testCase "NFixed add" do - add -$ initialStorageDec - @?= (2.2 :: NFixed (DecBase 3)) - , testCase "NFixed sub" do - sub -$ initialStorageDec - @?= (0 :: Fixed (DecBase 3)) - , testCase "NFixed mul" do - mul -$ initialStorageDec - @?= (1.21 :: NFixed (DecBase 6)) - , testCase "NFixed ediv 1" do - ediv -$ (123.456 :: NFixed (DecBase 3), 100 :: Integer) - @?= Just (1, 23.456 :: (NFixed (DecBase 3))) - , testCase "NFixed ediv 2" do - ediv -$ (2 :: NFixed (DecBase 3), 100 :: Integer) - @?= Just (0, 2 :: (NFixed (DecBase 3))) - ] - , testGroup "Binary base" - [ testCase "NFixed add" do - add -$ initialStorageBin - @?= (2.2 :: NFixed (BinBase 1)) - , testCase "NFixed sub" do - sub -$ initialStorageBin - @?= (0 :: Fixed (BinBase 1)) - , testCase "NFixed mul" do - mul -$ initialStorageBin - @?= (1.21 :: NFixed (BinBase 2)) - ] - , testGroup "Rounding" - [ testGroup "Rounding with decimal base" - [ testCase "Round up NFixed with decimal base 1" do - round_ -$ (1.23456 :: (NFixed (DecBase 6))) - @?= (1.235 :: NFixed (DecBase 3)) - , testCase "Round up NFixed with decimal base 2" do - round_ -$ (1.23446 :: (NFixed (DecBase 6))) - @?= (1.234 :: NFixed (DecBase 3)) - , testCase "Round up NFixed with decimal base 3" do - round_ -$ (0.177 :: (NFixed (DecBase 3))) - @?= (0.18 :: NFixed (DecBase 2)) - , testCase "Round up NFixed with decimal base 4" do - round_ -$ (0.173 :: (NFixed (DecBase 3))) - @?= (0.17 :: NFixed (DecBase 2)) - , testCase "Round up NFixed with decimal base 5" do - round_ -$ (1.230 :: (NFixed (DecBase 3))) - @?= (1.23 :: NFixed (DecBase 2)) - , testCase "Ceil 1" do - ceil_ -$ (0.177 :: (NFixed (DecBase 3))) - @?= (0.18 :: NFixed (DecBase 2)) - , testCase "Ceil 2" do - ceil_ -$ (0.173 :: (NFixed (DecBase 3))) - @?= (0.18 :: NFixed (DecBase 2)) - , testCase "Ceil 3" do - ceil_ -$ (1.230 :: (NFixed (DecBase 3))) - @?= (1.23 :: NFixed (DecBase 2)) - , testCase "Floor 1" do - floor_ -$ (0.177 :: (NFixed (DecBase 3))) - @?= (0.17 :: NFixed (DecBase 2)) - , testCase "Floor 2" do - floor_ -$ (0.173 :: (NFixed (DecBase 3))) - @?= (0.17 :: NFixed (DecBase 2)) - , testCase "Floor 3" do - floor_ -$ (1.230 :: (NFixed (DecBase 3))) - @?= (1.23 :: NFixed (DecBase 2)) - , testCase "Round down" do - round_ -$ (1.234 :: NFixed (DecBase 3)) - @?= (1.23400 :: (NFixed (DecBase 6))) - ] - , testGroup "Rounding with Binary Base" - [ testCase "Round NFixed with binary base" do - round_ -$ (0x1.23456 :: (NFixed (BinBase 6))) - @?= (0x1.235 :: NFixed (BinBase 3)) - , testCase "Ceil 1" do - ceil_ -$ (0x0.177 :: (NFixed (BinBase 3))) - @?= (0x0.18 :: NFixed (BinBase 2)) - , testCase "Ceil 2" do - ceil_ -$ (0x0.173 :: (NFixed (BinBase 3))) - @?= (0x0.18 :: NFixed (BinBase 2)) - , testCase "Ceil 3" do - ceil_ -$ (0x1.230 :: (NFixed (BinBase 12))) - @?= (0x1.23 :: NFixed (BinBase 8)) - , testCase "Floor 1" do - floor_ -$ (0x0.177 :: (NFixed (BinBase 3))) - @?= (0x0.17 :: NFixed (BinBase 2)) - , testCase "Floor 2" do - floor_ -$ (0x0.173 :: (NFixed (BinBase 3))) - @?= (0x0.17 :: NFixed (BinBase 2)) - , testCase "Floor 3" do - floor_ -$ (0x1.230 :: (NFixed (BinBase 3))) - @?= (0x1.23 :: NFixed (BinBase 2)) - ] - , testGroup "Casts" - [ testCase "Cast to Integer" do - fromFixed @(NFixed (DecBase 6)) -$ (1.23456 :: (NFixed (DecBase 6))) - @?= 1 - , testCase "Cast Integer to NFixed" do - toFixed @(NFixed (DecBase 6)) -$ (123456 :: Integer) - @?= (123456 :: (NFixed (DecBase 6))) - , testCase "Cast to Integer (Binary base)" do - fromFixed @(NFixed (BinBase 6)) -$ (1.23456 :: (NFixed (BinBase 6))) - @?= 1 - , testCase "Cast Integer to NFixed (Binary base)" do - toFixed @(NFixed (BinBase 6)) -$ (123456 :: Integer) - @?= (123456 :: (NFixed (BinBase 6))) - ] - ] - , testGroup "Division" - [ testCase "Divide big NFixed(Dec) to small NFixed(Dec)" do - div @(Maybe (NFixed (DecBase 8))) -$ (625.123 :: NFixed (DecBase 3), 123.23 :: NFixed (DecBase 2)) - @?= Just (5.07281506 :: NFixed (DecBase 8)) - , testCase "Divide small NFixed(Dec) to big NFixed(Dec)" do - div @(Maybe (NFixed (DecBase 8))) -$ (123.23 :: NFixed (DecBase 3), 625.123 :: NFixed (DecBase 2)) - @?= Just (0.19713015 :: NFixed (DecBase 8)) - , testCase "Divide big NFixed(Bin) to small NFixed(Bin)" do - div @(Maybe (NFixed (BinBase 8))) -$ (625.123 :: NFixed (BinBase 3), 123.23 :: NFixed (BinBase 2)) - @?= (Just (5.079 :: NFixed (BinBase 8))) - , testCase "Divide small NFixed(Bin) to big NFixed(Bin)" do - div @(Maybe (NFixed (BinBase 8))) -$ (123.23 :: NFixed (BinBase 3), 625.123 :: NFixed (BinBase 2)) - @?= (Just (0.19713015 :: NFixed (BinBase 8))) - , testCase "Divide by zero" do - div @(Maybe (NFixed (BinBase 8))) -$ (123.23 :: NFixed (BinBase 3), 0 :: NFixed (BinBase 2)) - @?= (Nothing) - ] - ] - where - initialStorageDec = - (1.1 :: NFixed (DecBase 3), 1.1 :: NFixed (DecBase 3)) - - initialStorageBin = - (1.1 :: NFixed (BinBase 1), 1.1 :: NFixed (BinBase 1)) diff --git a/lorentz-test/Test/Lorentz/CustomValue.hs b/lorentz-test/Test/Lorentz/CustomValue.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/CustomValue.hs +++ /dev/null @@ -1,283 +0,0 @@ --- 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. - -{-# OPTIONS_GHC -Wno-partial-fields #-} - -module Test.Lorentz.CustomValue - ( test_Custom_Values - ) where - -import Data.Typeable ((:~:)(..)) -import GHC.TypeNats (type (-)) -import Test.Tasty (TestTree) - -import Lorentz.Layouts.NonDupable -import Lorentz.Value -import Morley.Michelson.Typed.T - ----------------------------------------------------------------------------- --- Example data types ----------------------------------------------------------------------------- - -data CustomType a - = CustomUp Integer Integer - | CustomMid {unMid :: Natural} - | CustomDown a - | CustomNone - -$(customGeneric "CustomType" $ withDepths - [ cstr @3 [fld @1, fld @1] - , cstr @3 [fld @0] - , cstr @2 [fld @0] - , cstr @1 [] - ] - ) - -deriving anyclass instance IsoValue a => IsoValue (CustomType a) - -data KindaRightType - = KindaRightA - | KindaRightB Mutez Integer - | KindaRightC Mutez Natural - -$(customGeneric "KindaRightType" rightBalanced) - -deriving anyclass instance IsoValue KindaRightType - -data KindaLeftType - = KindaLeftA Integer Integer Integer - | KindaLeftB Natural Mutez Natural - -$(customGeneric "KindaLeftType" leftBalanced) - -deriving anyclass instance IsoValue KindaLeftType - -data VeryRightType - = VeryRightA - | VeryRightB - | VeryRightC - | VeryRightD - | VeryRightE - | VeryRightF - -$(customGeneric "VeryRightType" rightComb) - -deriving anyclass instance IsoValue VeryRightType - -data VeryLeftType = VeryLeft - { unA :: Integer - , unB :: Natural - , unC :: Mutez - , unD :: Natural - , unE :: Integer - } - -$(customGeneric "VeryLeftType" leftComb) - -deriving anyclass instance IsoValue VeryLeftType - -data HaskellLikeType = HaskellLike - { _ha :: Integer - , _hb :: Natural - , _hc :: Mutez - , _hd :: Natural - , _he :: Integer - } - -$(customGeneric "HaskellLikeType" haskellBalanced) - -deriving anyclass instance IsoValue HaskellLikeType - -data LigoType = LigoType - { _l1 :: () - , _l2 :: () - , _l3 :: () - , _l4 :: () - , _l5 :: () - , _l6 :: () - , _l7 :: () - , _l8 :: () - , _l9 :: () - , _l10 :: () - , _l11 :: () - , _l12 :: () - , _l13 :: () - } - -$(customGeneric "LigoType" ligoLayout) - -deriving anyclass instance IsoValue LigoType - -data LigoUnorderedType = LigoUnorderedType - { _lu5 :: () - , _lu1 :: Integer - , _lu2 :: Natural - , _lu3 :: MText - , _lu4 :: ByteString - } - -$(customGeneric "LigoUnorderedType" ligoLayout) - -deriving anyclass instance IsoValue LigoUnorderedType - -data LigoSumType - = LigoSumTypeB Integer - | LigoSumTypeA () - -$(customGeneric "LigoSumType" ligoLayout) - -deriving anyclass instance IsoValue LigoSumType - -data LigoCombType = LigoCombType - { _lc5 :: Integer - , _lc1 :: () - , _lc2 :: () - , _lc3 :: () - , _lc4 :: () - } - -$(customGeneric "LigoCombType" ligoCombLayout) - -deriving anyclass instance IsoValue LigoCombType - -data LigoCombSumType - = LigoCombSumTypeB Integer - | LigoCombSumTypeA () - -$(customGeneric "LigoCombSumType" ligoCombLayout) - -deriving anyclass instance IsoValue LigoCombSumType - -newtype NewType a = NewType (CustomType a) - -$(customGeneric "NewType" haskellBalanced) - -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 ----------------------------------------------------------------------------- - -type ExpectedCustomValue a = - 'TOr ('TOr ('TOr ('TPair 'TInt 'TInt) 'TNat) (ToT a)) 'TUnit - -type ExpectedKindaRightValue = - 'TOr 'TUnit ('TOr ('TPair 'TMutez 'TInt) ('TPair 'TMutez 'TNat)) - -type ExpectedKindaLeftValue = - 'TOr ('TPair ('TPair 'TInt 'TInt) 'TInt) ('TPair ('TPair 'TNat 'TMutez) 'TNat) - -type ExpectedVeryRightValue = - 'TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit 'TUnit)))) - -type ExpectedVeryLeftValue = - 'TPair ('TPair ('TPair ('TPair 'TInt 'TNat) 'TMutez) 'TNat) 'TInt - -data HaskellTrueType = HaskellTrue - { _ha' :: Integer - , _hb' :: Natural - , _hc' :: Mutez - , _hd' :: Natural - , _he' :: Integer - } deriving stock (Generic) - deriving anyclass (IsoValue) - -type ExpectedHaskellLikeValue = - ToT HaskellTrueType - -type family CompletePairTree n e where - CompletePairTree 0 e = e - CompletePairTree k e = - 'TPair (CompletePairTree (k - 1) e) (CompletePairTree (k - 1) e) - -type ExpectedLigoValue = - 'TPair - (CompletePairTree 3 'TUnit) - ('TPair - (CompletePairTree 2 'TUnit) - 'TUnit - ) - -type ExpectedLigoUnorderedValue = - 'TPair ('TPair ('TPair 'TInt 'TNat) ('TPair 'TString 'TBytes)) 'TUnit - -type ExpectedLigoSumValue = - 'TOr 'TUnit 'TInt - -type ExpectedLigoCombValue = - 'TPair 'TInt $ 'TPair 'TUnit $ 'TPair 'TUnit $ 'TPair 'TUnit 'TUnit - -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 ----------------------------------------------------------------------------- - --- Fake tests to deceive "weeder". --- We only do typechecking in this module. -test_Custom_Values :: [TestTree] -test_Custom_Values = [] - where - _nonSense = (unMid, unA, unB, unC, unD, unE) - -_checkWithDepths :: ToT (CustomType a) :~: (ExpectedCustomValue a) -_checkWithDepths = Refl - -_checkRightBalanced :: ToT KindaRightType :~: ExpectedKindaRightValue -_checkRightBalanced = Refl - -_checkLeftBalanced :: ToT KindaLeftType :~: ExpectedKindaLeftValue -_checkLeftBalanced = Refl - -_checkRightComb :: ToT VeryRightType :~: ExpectedVeryRightValue -_checkRightComb = Refl - -_checkLeftComb :: ToT VeryLeftType :~: ExpectedVeryLeftValue -_checkLeftComb = Refl - -_checkHaskellLike :: ToT HaskellLikeType :~: ExpectedHaskellLikeValue -_checkHaskellLike = Refl - -_checkLigoLayout :: ToT LigoType :~: ExpectedLigoValue -_checkLigoLayout = Refl - -_checkLigoLayout2 :: ToT LigoUnorderedType :~: ExpectedLigoUnorderedValue -_checkLigoLayout2 = Refl - -_checkLigoLayout3 :: ToT LigoSumType :~: ExpectedLigoSumValue -_checkLigoLayout3 = Refl - -_checkLigoCombLayout1 :: ToT LigoCombType :~: ExpectedLigoCombValue -_checkLigoCombLayout1 = Refl - -_checkLigoCombLayout2 :: ToT LigoCombSumType :~: ExpectedLigoCombSumValue -_checkLigoCombLayout2 = Refl - -_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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/DeadCode.hs +++ /dev/null @@ -1,61 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- TODO [#549]: remove this pragma -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | Tests checking dead code avoidance in Lorentz. - -module Test.Lorentz.DeadCode - ( test_Test - ) where - - -import Control.Spoon (spoon) -import Test.HUnit (Assertion, assertBool, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz qualified as L -import Lorentz.Base -import Lorentz.Run -import Morley.Michelson.Typed (Instr(Seq)) -import Morley.Michelson.Typed qualified as T - -test_Test :: [TestTree] -test_Test = - [ testCase "Can construct normal instructions" $ - L.push @Integer 5 # L.drop - `compilesTo` (T.PUSH (T.toVal @Integer 5) `Seq` T.DROP) - - , testCase "Dead code is cut off" $ - (L.unit # L.failWith) # L.drop - `compilesTo` (T.UNIT `Seq` T.FAILWITH) - - , testCase "Dead code after all failing if branches is cut off" $ - (L.push True # L.if_ L.failWith L.failWith) # L.drop - `compilesTo` (T.PUSH (T.toVal True) `Seq` T.IF T.FAILWITH T.FAILWITH) - - , testCase "Always failing DIP body is error" $ - L.dip (L.unit # L.failWith) - & fails - - , testCase "Never is also \"failing\"" $ - compilesTo' - ((L.never # L.push @Integer 5) # L.drop) - T.NEVER - ] - where - compilesTo' :: '[i] :-> s -> Instr '[T.ToT i] (T.ToTs s) -> Assertion - compilesTo' linstr instr = - compileLorentzWithOptions - (defaultCompilationOptions { coOptimizerConf = Nothing }) - linstr - @?= instr - - compilesTo = compilesTo' @() - infixr 0 `compilesTo` - - fails instr = - assertBool "instruction construction didn't fail" . isNothing . spoon $ - compileLorentz instr diff --git a/lorentz-test/Test/Lorentz/Doc/Positions.hs b/lorentz-test/Test/Lorentz/Doc/Positions.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Doc/Positions.hs +++ /dev/null @@ -1,23 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on ordering of documentation items. -module Test.Lorentz.Doc.Positions - ( test_Errors - ) where - -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz.Errors -import Lorentz.Errors.Numeric -import Test.Cleveland.Util (assertGoesBefore) - -test_Errors :: [TestTree] -test_Errors = - [ testCase "Error tag mapping is described before errors" $ - -- This is required because when @Errors@ section is modified - -- to mention numeric error tags, it needs some clarification - -- provided by @About error tag mapping@ section. - Proxy @DDescribeErrorTagMap `assertGoesBefore` Proxy @DError - ] diff --git a/lorentz-test/Test/Lorentz/DupableScan.hs b/lorentz-test/Test/Lorentz/DupableScan.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/DupableScan.hs +++ /dev/null @@ -1,97 +0,0 @@ --- 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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Entrypoints.hs +++ /dev/null @@ -1,526 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. -module Test.Lorentz.Entrypoints - ( test_FieldEntrypoints - , test_TypeEntrypoints - , test_RootEntrypoints - , test_Entrypoints_lookup - , test_Contract_call - , test_Self_call - ) where - - -import Fcf (Eval) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.TypeSpec (typeTest) -import Test.TypeSpec (Is, TypeSpec(..)) - -import Lorentz ((#), (/->)) -import Lorentz qualified as L -import Lorentz.Annotation -import Lorentz.Constraints -import Lorentz.Entrypoints -import Lorentz.Run -import Lorentz.Value -import Morley.Michelson.Typed hiding (Contract) -import Morley.Michelson.Untyped (RootAnn, noAnn) -import Morley.Util.Named -import Test.Cleveland - -import Test.Util.Annotation -import Test.Util.TypeSpec (ExactlyIs) - ----------------------------------------------------------------------------- --- Entrypoints declarations ----------------------------------------------------------------------------- - -data MyEntrypoints1 - = Do1 Integer - | Do2 (Integer, Integer) - | Do3 MyEntrypoints2 - | Do4 MyParams - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints1a - = Do1a Integer - | Do2a (Integer, Integer) - | Do3a MyEntrypoints2 - | Do4a MyParams - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints2 - = Do10 - | Do11 Natural - deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyEntrypoints3 - = Do12 ("tuplearg" :! ("TL" :! Integer, "TR" :! Natural), "boolarg" :! Bool) - | Do13 ("integerarg" :! Integer, "boolarg" :! Bool) - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints4 - = Do14 ("viewarg1" :! L.View_ ("owner" :! L.Address) Natural) - | Do15 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints5 - = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural)) - | Do17 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints6 - = Do18 ("lambdaarg" :! L.Lambda Natural Natural) - | Do19 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints7 - = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)]) - | Do21 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints8 - = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address))) - | Do23 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints9 - = Do24 ("maybearg" :? ("maybeinner" :! Natural)) - | Do25 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints10 - = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ()) - | Do27 () - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypoints11 - = Do28 ("kek" :! Natural, "pek" :! Integer) - | Do29 - deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyEntrypointsWithDef - = Default Integer - | NonDefault Natural - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypointsWithRoot - = Dor1 - | Dor2 Natural - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypointsWithCustomAnn - = Doc1 Natural - | Doc2 CustomProd - deriving stock Generic - deriving anyclass (IsoValue) - -data CustomProd = CustomProd - { cp1 :: Natural - , cp2 :: CustomSum - } - deriving stock Generic - deriving anyclass (IsoValue) - -instance HasAnnotation CustomProd where - annOptions = defaultAnnOptions {fieldAnnModifier = \a -> "prod_" <> a} - -data CustomSum = Cs1 | Cs2 - deriving stock Generic - deriving anyclass (IsoValue) - -instance HasAnnotation CustomSum where - annOptions = defaultAnnOptions {fieldAnnModifier = \a -> "sum_" <> a} - -data MyParams = MyParams - { param1 :: () - , param2 :: ByteString - } - deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - --- Normally this cannot declare entrypoints because this is not a sum type. --- But we will declare them forcibly -data MySingleEntrypoint = Dos1 Integer - deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyEntrypointsDelegated - = Dod1 - | Dod2 MyEntrypointsSubDelegated - deriving stock Generic - deriving anyclass (IsoValue) - -data MyEntrypointsSubDelegated - = Dosd1 - | Dosd2 - deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -instance ParameterHasEntrypoints MyEntrypoints1 where - type ParameterEntrypointsDerivation MyEntrypoints1 = EpdRecursive - -instance ParameterHasEntrypoints MyEntrypoints1a where - type ParameterEntrypointsDerivation MyEntrypoints1a = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints2 where - type ParameterEntrypointsDerivation MyEntrypoints2 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints3 where - type ParameterEntrypointsDerivation MyEntrypoints3 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints4 where - type ParameterEntrypointsDerivation MyEntrypoints4 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints5 where - type ParameterEntrypointsDerivation MyEntrypoints5 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints6 where - type ParameterEntrypointsDerivation MyEntrypoints6 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints7 where - type ParameterEntrypointsDerivation MyEntrypoints7 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints8 where - type ParameterEntrypointsDerivation MyEntrypoints8 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints9 where - type ParameterEntrypointsDerivation MyEntrypoints9 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints10 where - type ParameterEntrypointsDerivation MyEntrypoints10 = EpdPlain - -instance ParameterHasEntrypoints MyEntrypoints11 where - type ParameterEntrypointsDerivation MyEntrypoints11 = EpdNone - -instance ParameterHasEntrypoints MyEntrypointsWithDef where - type ParameterEntrypointsDerivation MyEntrypointsWithDef = EpdPlain - -instance ParameterHasEntrypoints (ShouldHaveEntrypoints MySingleEntrypoint) where - type ParameterEntrypointsDerivation (ShouldHaveEntrypoints MySingleEntrypoint) = EpdPlain - -instance ParameterHasEntrypoints MyEntrypointsDelegated where - type ParameterEntrypointsDerivation MyEntrypointsDelegated = EpdDelegate - -instance ParameterHasEntrypoints MyEntrypointsSubDelegated where - type ParameterEntrypointsDerivation MyEntrypointsSubDelegated = EpdNone - -instance ParameterHasEntrypoints MyEntrypointsWithRoot where - type ParameterEntrypointsDerivation MyEntrypointsWithRoot = EpdWithRoot "root" EpdPlain - -instance ParameterHasEntrypoints MyEntrypointsWithCustomAnn where - type ParameterEntrypointsDerivation MyEntrypointsWithCustomAnn = EpdPlain - -dummyContract :: NiceParameterFull param => Contract param () () -dummyContract = L.defaultContract $ - L.drop L.# L.unit L.# L.nil L.# L.pair - -test_FieldEntrypoints :: [TestTree] -test_FieldEntrypoints = - [ testCase "Simple parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints2) - @?= - FANodeOr - "do10" FALeaf - "do11" FALeaf - - , testGroup "Complex parameter" - [ testCase "Interpreting as direct list of entrypoints" $ - (paramAnnTree $ dummyContract @MyEntrypoints1a) - @?= - FANodeOr - noAnn (FANodeOr "do1a" FALeaf "do2a" FALeaf) - noAnn - (FANodeOr - "do3a" - (FANodeOr noAnn FALeaf noAnn FALeaf) - "do4a" - (FANodePair "param1" FALeaf "param2" FALeaf)) - - , testCase "Recursive entrypoints traversal" $ - (paramAnnTree $ dummyContract @MyEntrypoints1) - @?= - FANodeOr - noAnn (FANodeOr "do1" FALeaf "do2" FALeaf) - noAnn (FANodeOr - noAnn - (FANodeOr "do10" FALeaf "do11" FALeaf) - "do4" - (FANodePair - "param1" FALeaf - "param2" FALeaf) - ) - - , testCase "Delegating entrypoints traversal" $ - (paramAnnTree $ dummyContract @MyEntrypointsDelegated) - @?= - FANodeOr "dod1" FALeaf - "dod2" (FANodeOr noAnn FALeaf noAnn FALeaf) - , testCase "Parameter with custom fieldAnnotation" $ - (paramAnnTree $ dummyContract @MyEntrypointsWithCustomAnn) - @?= - FANodeOr - "doc1" FALeaf - "doc2" - (FANodePair - "prod_cp1" FALeaf - "prod_cp2" - (FANodeOr - "sum_cs1" FALeaf - "sum_cs2" FALeaf - ) - ) - ] - ] - where - paramAnnTree :: Contract cp st () -> FieldAnnTree (ToT cp) - paramAnnTree = extractFieldAnnTree . pnNotes . cParamNotes . L.toMichelsonContract - -test_TypeEntrypoints :: [TestTree] -test_TypeEntrypoints = - [ testCase "Named field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints3) - @?= - (TANodeOr noAnn - (TANodePair noAnn (TANodePair "tuplearg" (TALeaf "TL") (TALeaf "TR")) (TALeaf "boolarg")) - (TANodePair noAnn (TALeaf "integerarg") (TALeaf "boolarg")) - ) - , testCase "Named field parameter for views" $ - (paramAnnTree $ dummyContract @MyEntrypoints4) - @?= - (TANodeOr noAnn - (TANodePair "viewarg1" (TALeaf "owner") (TALeaf noAnn)) (TALeaf noAnn)) - - , testCase "Maybe field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints5) - @?= - (TANodeOr noAnn - (TANodeOption "maybearg" (TALeaf "maybeinner")) (TALeaf noAnn)) - - , testCase "Lambda field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints6) - @?= - (TANodeOr noAnn - (TANodeLambda "lambdaarg" (TALeaf noAnn) (TALeaf noAnn)) (TALeaf noAnn)) - - , testCase "List field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints7) - @?= - (TANodeOr noAnn - (TANodeList "listarg" (TANodePair noAnn (TALeaf "balance") (TALeaf "address"))) (TALeaf noAnn)) - - , testCase "Map field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints8) - @?= - (TANodeOr noAnn - (TANodeMap - "maparg" - (TALeaf noAnn) - (TANodePair noAnn (TALeaf "balance") (TALeaf "address")) - ) - (TALeaf noAnn) - ) - - , testCase "Maybe field parameter 2" $ - (paramAnnTree $ dummyContract @MyEntrypoints9) - @?= - (TANodeOr noAnn - (TANodeOption "maybearg" (TALeaf "maybeinner")) (TALeaf noAnn)) - - , testCase "Big map field parameter" $ - (paramAnnTree $ dummyContract @MyEntrypoints10) - @?= - (TANodeOr noAnn - (TANodeLambda "bigmaparg" - (TANodeBigMap - noAnn - (TALeaf noAnn) - (TANodePair noAnn (TALeaf "balance") (TALeaf "address")) - ) - (TALeaf noAnn) - ) - (TALeaf noAnn) - ) - - , testCase "Newtype" $ - (paramAnnTree $ dummyContract @(ShouldHaveEntrypoints MySingleEntrypoint)) - @?= - TALeaf noAnn - - , testGroup "Primitive type parameter" - -- Parameters used in these test cases should not require any instances - [ testCase "Address" $ - (paramAnnTree $ dummyContract @Address) - @?= - TALeaf noAnn - , testCase "Void" $ - (paramAnnTree $ dummyContract @(L.Void_ Integer Natural)) - @?= - TANodePair noAnn (TALeaf noAnn) (TANodeLambda noAnn (TALeaf noAnn) (TALeaf noAnn)) - ] - , testCase "EpdNone case (type annotations are preserved)" $ - (paramAnnTree $ dummyContract @MyEntrypoints11) - @?= - (TANodeOr noAnn - (TANodePair noAnn (TALeaf "kek") (TALeaf "pek")) - (TALeaf noAnn) - ) - ] - where - paramAnnTree :: Contract cp st () -> TypeAnnTree (ToT cp) - paramAnnTree = extractTypeAnnTree . pnNotes . cParamNotes . L.toMichelsonContract - -test_RootEntrypoints :: [TestTree] -test_RootEntrypoints = - [ testCase "No root entrypoint" $ - (rootAnn $ dummyContract @MyEntrypoints1) - @?= - noAnn - - , testCase "With root entrypoint" $ - (rootAnn $ dummyContract @MyEntrypointsWithRoot) - @?= - "root" - ] - where - rootAnn :: Contract cp st () -> RootAnn - rootAnn = pnRootAnn . cParamNotes . L.toMichelsonContract - ----------------------------------------------------------------------------- --- @contract@ instruction ----------------------------------------------------------------------------- - -test_Entrypoints_lookup :: [TestTree] -test_Entrypoints_lookup = - [ testGroup "Flat parameter type" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntrypointArg MyEntrypoints1a `Is` MyEntrypoints1a) - , typeTest "Can get entrypoint on surface" $ Valid @ - (GetEntrypointArg MyEntrypoints1a "Do1a" `Is` Integer) - , typeTest "Cannot get entrypoint in deep" $ Valid @ - (Eval (LookupParameterEntrypoint MyEntrypoints1a "Do11") - `ExactlyIs` 'Nothing - ) - ] - , testGroup "Nested parameter type" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntrypointArg MyEntrypoints1 `Is` MyEntrypoints1) - , typeTest "Can get entrypoint on surface" $ Valid @ - (GetEntrypointArg MyEntrypoints1 "Do1" `Is` Integer) - , typeTest "Can get entrypoint in deep" $ Valid @ - (GetEntrypointArg MyEntrypoints1 "Do11" `Is` Natural) - , typeTest "Can get entrypoint without arg" $ Valid @ - (GetEntrypointArg MyEntrypoints1 "Do10" `Is` ()) - ] - , testGroup "Parameter type with default entrypoint" - [ typeTest "Default entrypoint arg" $ Valid @ - (GetDefaultEntrypointArg MyEntrypointsWithDef `Is` Integer) - , typeTest "Can get non-default entrypoint" $ Valid @ - (GetEntrypointArg MyEntrypointsWithDef "NonDefault" `Is` Natural) - ] - , testGroup "Delegation" - [ typeTest "Calling immediate entrypoint works" $ Valid @ - (GetEntrypointArg MyEntrypointsDelegated "Dod1" `Is` ()) - ] - ] - --- | A contract which accepts 'Address' as parameter and calls specific --- entrypoint of another contract. -callerContract - :: forall cp mname arg. - ( arg ~ GetEntrypointArgCustom cp mname - , NiceConstant arg, NiceParameter arg, NiceParameterFull cp - ) - => EntrypointRef mname - -> arg - -> Contract (TAddress cp ()) () () -callerContract epRef argument = L.defaultContract $ - L.car # L.contractCalling epRef # - L.assertSome ("Contract lookup failed" :: MText) # - L.push 1 # L.push argument # L.transferTokens # - L.dip (L.unit # L.nil) # L.cons # L.pair - -test_Contract_call :: [TestTree] -test_Contract_call = - [ testScenario "Calling entrypoint" $ scenario do - let myCallerContract = callerContract (Call @"Do11") 5 - let myTargetContract = L.defaultContract $ L.car # L.caseT @MyEntrypoints2 - ( #cDo10 /-> L.push 0 - , #cDo11 /-> L.nop - ) # L.nil # L.pair - - caller <- originate $ OriginateData "Caller" 10 () myCallerContract - target <- originateSimple "Call target" def myTargetContract - call caller CallDefault (toTAddress target) - getStorage target @@== 5 - - , testScenario "Calling default entrypoint" $ scenario do - let myCallerContract = callerContract CallDefault 3 - let myTargetContract = L.defaultContract $ L.car # L.caseT @MyEntrypointsWithDef - ( #cDefault /-> L.nop - , #cNonDefault /-> L.neg - ) # L.nil # L.pair - - caller <- originate$ OriginateData "Caller" 10 () myCallerContract - target <- originateSimple "Call target" def myTargetContract - call caller CallDefault (toTAddress target) - getStorage target @@== 3 - - , testScenario "Calling root entrypoint" $ scenario do - let myCallerContract = callerContract (Call @"root") (Dor2 5) - let myTargetContract = L.defaultContract $ L.car # L.caseT @MyEntrypointsWithRoot - ( #cDor1 /-> L.push 0 - , #cDor2 /-> L.nop - ) # L.nil # L.pair - - caller <- originate $ OriginateData "Caller" 10 () myCallerContract - target <- originateSimple "Call target" def myTargetContract - call caller CallDefault (toTAddress target) - getStorage target @@== 5 - ] - -test_Self_call :: [TestTree] -test_Self_call = - [ testScenario "Calling entrypoint" $ scenario do - let myContract = mkContract $ L.car # L.caseT @MyEntrypoints2 - ( #cDo10 /-> - L.selfCalling @MyEntrypoints2 (Call @"Do11") # - L.push 1 # L.push 5 # L.transferTokens # - L.dip (L.push @Integer 1 # L.nil) # L.cons # L.pair - , #cDo11 /-> L.push @Integer 10 # L.add # L.nil # L.pair - ) - - contractRef <- originate $ OriginateData "Contract" 10 0 myContract - call contractRef CallDefault Do10 - getStorage contractRef @@== 15 - - , testScenario "Calling root entrypoint" $ scenario do - let myContract = L.defaultContract $ L.car # L.caseT @MyEntrypointsWithRoot - ( #cDor1 /-> - L.selfCalling @MyEntrypointsWithRoot (Call @"root") # - L.push 1 # L.push (Dor2 5) # L.transferTokens # - L.dip (L.push @Integer 1 # L.nil) # L.cons # L.pair - , #cDor2 /-> - L.push @Integer 10 # L.add # L.nil # L.pair - ) - contractRef <- originate $ OriginateData "Contract" 10 0 myContract - call contractRef CallDefault Dor1 - getStorage contractRef @@== 15 - ] diff --git a/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs b/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Entrypoints/Doc.hs +++ /dev/null @@ -1,234 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on autodoc for entrypoints. -module Test.Lorentz.Entrypoints.Doc - ( test_ParamBuildingSteps_are_correct - , test_Finalization_check - , unit_Uncallables_detection - ) where - -import Control.Spoon (teaspoon) -import Test.HUnit (Assertion, assertBool, (@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Lorentz ((/->), (:->)) -import Lorentz qualified as L -import Lorentz.Annotation -import Lorentz.Doc -import Lorentz.Entrypoints -import Lorentz.Entrypoints.Doc -import Lorentz.Value -import Morley.Michelson.Untyped (EpName(..)) -import Test.Cleveland.Doc.Lorentz - --- Parameters ----------------------------------------------------------------------------- - -data MySub - = Dos1 - | Dos2 - deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) - -instance TypeHasDoc MySub where - typeDocMdDescription = "MySub" - -mySubImpl :: '[MySub] :-> '[] -mySubImpl = L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDos1 /-> L.nop - , #cDos2 /-> L.nop - ) - -data MyPlainEps - = Do1 Integer - | Do2 MySub - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyPlainEps where - typeDocMdDescription = "MyPlainEps" - -instance ParameterHasEntrypoints MyPlainEps where - type ParameterEntrypointsDerivation MyPlainEps = EpdPlain - -myPlainImplDumb :: '[MyPlainEps] :-> '[] -myPlainImplDumb = L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDo1 /-> L.drop - , #cDo2 /-> mySubImpl - ) - -myPlainImpl :: '[MyPlainEps] :-> '[] -myPlainImpl = finalizeParamCallingDoc myPlainImplDumb - -data MyRecursiveEps - = Dor1 Integer - | Dor2 MySub - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints MyRecursiveEps where - type ParameterEntrypointsDerivation MyRecursiveEps = EpdRecursive - -myRecursiveImpl :: '[MyRecursiveEps] :-> '[] -myRecursiveImpl = finalizeParamCallingDoc $ - L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDor1 /-> L.drop - , #cDor2 /-> mySubImpl - ) - -data MyDelegateEps - = Dod1 Integer - | Dod2 MyPlainEps - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints MyDelegateEps where - type ParameterEntrypointsDerivation MyDelegateEps = EpdDelegate - -myDelegateImpl :: '[MyDelegateEps] :-> '[] -myDelegateImpl = finalizeParamCallingDoc $ - L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDod1 /-> L.drop - , #cDod2 /-> myPlainImplDumb - ) - -myDelegateImplFinalizedTwice :: '[MyDelegateEps] :-> '[] -myDelegateImplFinalizedTwice = finalizeParamCallingDoc $ - L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDod1 /-> L.drop - , #cDod2 /-> myPlainImpl - ) - -data MyDefEps - = Do0 - | Default - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance TypeHasDoc MyDefEps where - typeDocMdDescription = "MyDefEps" - -instance ParameterHasEntrypoints MyDefEps where - type ParameterEntrypointsDerivation MyDefEps = EpdPlain - -myDefImplDumb :: '[MyDefEps] :-> '[] -myDefImplDumb = - L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDo0 /-> L.nop - , #cDefault /-> L.nop - ) - -myDefImpl :: '[MyDefEps] :-> '[] -myDefImpl = finalizeParamCallingDoc myDefImplDumb - -data MyRecursiveDefEps - = Dord1 MySub - | Dord2 MyDefEps - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints MyRecursiveDefEps where - type ParameterEntrypointsDerivation MyRecursiveDefEps = EpdRecursive - -myRecursiveDefImpl :: '[MyRecursiveDefEps] :-> '[] -myRecursiveDefImpl = finalizeParamCallingDoc $ - L.entryCase (Proxy @PlainEntrypointsKind) - ( #cDord1 /-> mySubImpl - , #cDord2 /-> myDefImplDumb - ) - --- Tests ----------------------------------------------------------------------------- - --- Similar to 'ParamBuildingSteps', but without details irrelevant for testing -data ParamBuildingType - -- | Wrap into constructor with given name - -- NB: starts with capital letter - = PbtWrapIn Text - -- | Call given entrypoint - -- NB: starts with lowercase letter - | PbtCallEntrypoint Text - -- | Does something weird - | PbtCustom - -- | Entrypoint cannot be called - | PbtUncallable - deriving stock (Show, Eq) - -pbsType :: ParamBuildingStep -> ParamBuildingType -pbsType = \case - PbsWrapIn ctor _ -> PbtWrapIn ctor - PbsCallEntrypoint (unEpName -> ep) -> PbtCallEntrypoint ep - PbsCustom _ -> PbtCustom - PbsUncallable _ -> PbtUncallable - -getAllBuildingSteps :: (i :-> o) -> [[ParamBuildingType]] -getAllBuildingSteps instr = - map pbsType . epaBuilding <$> allContractDocItems (buildDocTest instr) - -test_ParamBuildingSteps_are_correct :: [TestTree] -test_ParamBuildingSteps_are_correct = - [ testCase "Simple entrypoints without direct calling" $ - getAllBuildingSteps myPlainImplDumb - @?= [ [PbtWrapIn "Do1"] - , [PbtWrapIn "Do2"] - , [PbtWrapIn "Do2", PbtWrapIn "Dos1"] - , [PbtWrapIn "Do2", PbtWrapIn "Dos2"] - ] - - , testCase "Simple entrypoints" $ - getAllBuildingSteps myPlainImpl - @?= [ [PbtCallEntrypoint "do1"] - , [PbtCallEntrypoint "do2"] - , [PbtCallEntrypoint "do2", PbtWrapIn "Dos1"] - , [PbtCallEntrypoint "do2", PbtWrapIn "Dos2"] - ] - , testCase "Recursive entrypoints" $ - getAllBuildingSteps myRecursiveImpl - @?= [ [PbtCallEntrypoint "dor1"] - , [PbtCallEntrypoint "", PbtWrapIn "Dor2"] - , [PbtCallEntrypoint "dos1"] - , [PbtCallEntrypoint "dos2"] - ] - , testCase "Delegate entrypoints" $ - getAllBuildingSteps myDelegateImpl - @?= [ [PbtCallEntrypoint "dod1"] - , [PbtCallEntrypoint "dod2"] - , [PbtCallEntrypoint "do1"] - , [PbtCallEntrypoint "do2"] - , [PbtCallEntrypoint "do2", PbtWrapIn "Dos1"] - , [PbtCallEntrypoint "do2", PbtWrapIn "Dos2"] - ] - - , testGroup "With explicit default" - [ testCase "Simple" $ - getAllBuildingSteps myDefImpl - @?= [ [PbtCallEntrypoint "do0"] - , [PbtCallEntrypoint ""] - ] - , testCase "Recursive" $ - getAllBuildingSteps myRecursiveDefImpl - @?= [ [PbtUncallable] -- Dord1 itself - , [PbtCallEntrypoint "dos1"] - , [PbtCallEntrypoint "dos2"] - , [PbtUncallable] -- Dord2 itself - , [PbtCallEntrypoint "do0"] - , [PbtCallEntrypoint ""] - ] - ] - ] - -test_Finalization_check :: [TestTree] -test_Finalization_check = - [ testCase "Cannot apply second time" $ - assertBool "Finalization unexpectedly didn't fail second time" $ - isNothing $ teaspoon myDelegateImplFinalizedTwice - ] - --- | Note [doc for uncallable entrypoints]: --- This test is a proof of that sometimes not all entrypoints are callable. -unit_Uncallables_detection :: Assertion -unit_Uncallables_detection = - expectDocTestFailure testAllEntrypointsAreCallable - myRecursiveDefImpl diff --git a/lorentz-test/Test/Lorentz/Errors.hs b/lorentz-test/Test/Lorentz/Errors.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Errors.hs +++ /dev/null @@ -1,121 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Test.Lorentz.Errors - ( unit_gatherErrorTags - , unit_Numeric_simple - , unit_Numeric_append - , test_errorFromValNumeric - ) where - -import Lorentz as L - -import Data.Bimap qualified as Bimap -import Data.HashSet qualified as HS -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (Assertion, (@?=)) - -import Test.Cleveland - ----------------------------------------------------------------------------- --- Numeric representation ----------------------------------------------------------------------------- - -unit_gatherErrorTags :: Assertion -unit_gatherErrorTags = sampleGatheredTags @?= HS.fromList [str1, str2] - -unit_Numeric_simple :: Assertion -unit_Numeric_simple = useNumericErrors sample @?= - (sampleNumericErrors (0, 1), Bimap.fromList [(0, str1), (1, str2)]) - -unit_Numeric_append :: Assertion -unit_Numeric_append = - applyErrorTagMap newMap sample @?= - sampleNumericErrors (5, 4) - where - existingMap :: ErrorTagMap - existingMap = Bimap.fromList [(4, str2)] - - newMap = existingMap `addNewErrorTags` sampleGatheredTags - -type instance ErrorArg "aa" = Bool -instance CustomErrorHasDoc "aa" where - customErrClass = ErrClassActionException - customErrDocMdCause = "patak" - -sample :: '[ MText] :-> '[ MText] -sample = - pushTrue # - -- FailWithString - if_ - (push str1 # failWith) - pushTrue # - -- Non-typical fail - if_ - (push str1 # push str1 # pair # pair # failWith) - pushTrue # - -- FailWithStackValue - if_ - (push str1 # pair # failWith) - (pushTrue) # - -- FailWithStackValue via 'failCustom' - if_ - (pushTrue # failCustom #aa) - (none @()) # - -- Deeper FailWithString - ifNone - (unit # pushTrue # if_ (push str2 # failWith) nop) - nop # - -- FailWithConstantPair - push (str2, ()) # failWith - --- Arguments are numeric codes for 'str1' and 'str2'. -sampleNumericErrors :: (Natural, Natural) -> '[ MText] :-> '[ MText] -sampleNumericErrors (code1, code2) = - pushTrue # - if_ - (push code1 # failWith) - pushTrue # - - if_ - (push str1 # push str1 # pair # pair # failWith) - pushTrue # - - if_ - (push code1 # pair # failWith) - pushTrue # - - -- Here we lose doc item and rely on the fact that instructions are - -- compared by transpiling them to Michelson. - if_ - (pushTrue # push code1 # pair # failWith) - (none @()) # - - ifNone - (unit # pushTrue # if_ (push code2 # failWith) nop) - nop # - - push (code2, ()) # failWith - -sampleGatheredTags :: HashSet MText -sampleGatheredTags = gatherErrorTags sample - -pushTrue :: forall s. s :-> Bool ': s -pushTrue = push True - -str1, str2 :: MText -str1 = "Aa" -str2 = "Qq" - -test_errorFromValNumeric :: TestTree -test_errorFromValNumeric = testScenario "Expect Numeric Error" $ scenario do - let - (voidSample', errorTagMap) = useNumericErrors voidSample - ref <- originate $ OriginateData "voidSample" minBound () (defaultContract voidSample') - expectNumericError errorTagMap (VoidResult False) $ call ref CallDefault (mkVoid True) - -voidSample :: ContractCode (Void_ Bool Bool) () -voidSample = car # void_ L.not diff --git a/lorentz-test/Test/Lorentz/Errors/Numeric.hs b/lorentz-test/Test/Lorentz/Errors/Numeric.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Errors/Numeric.hs +++ /dev/null @@ -1,70 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Test.Lorentz.Errors.Numeric - ( test_Documentation - ) where - -import Data.Typeable (eqT) -import Test.HUnit (assertFailure) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz qualified as L -import Lorentz.Base -import Lorentz.Doc -import Lorentz.Errors -import Lorentz.Errors.Numeric -import Morley.Michelson.Doc (lookupDocBlockSection) -import Test.Cleveland.Doc.Lorentz -import Test.Cleveland.Instances () - -type instance ErrorArg "myError" = UnitErrorArg -type instance ErrorArg "myNonMappedError" = UnitErrorArg - -instance CustomErrorHasDoc "myError" where - customErrClass = ErrClassActionException - customErrDocMdCause = "An error happened" - -instance CustomErrorHasDoc "myNonMappedError" where - customErrClass = ErrClassActionException - customErrDocMdCause = "A non-mapped error happened" - -contract :: Lambda () () -contract = - L.push True # - L.if_ (L.failCustom_ #myError) - (L.failCustom_ #myNonMappedError) - -errorTagMap :: ErrorTagMap -errorTagMap = - excludeErrorTags (one "MyNonMappedError") $ - buildErrorTagMap $ gatherErrorTags contract - -test_Documentation :: [TestTree] -test_Documentation = - [ testCase "Documentation is updated" $ do - let docum = buildDocTest $ applyErrorTagToErrorsDoc errorTagMap contract - contents = cdContents docum - dThrows = lookupDocBlockSection @DThrows contents - ?: error "Suddenly found no DThrow doc items" - - let - throws :: forall (e :: Type). Typeable e => DThrows -> Bool - throws (DThrows (_ :: Proxy e')) = isJust $ eqT @e @e' - - anyThrows :: forall (e :: Type). Typeable e => Bool - anyThrows = any (throws @e) dThrows - - when (anyThrows @(CustomError "myError")) $ - assertFailure "Old 'myError' remained" - unless (anyThrows @(NumericErrorWrapper 0 (CustomError "myError"))) $ - assertFailure "Mapped 'myError' does not appear in the result with tag 0" - - unless (anyThrows @(CustomError "myNonMappedError")) $ - assertFailure "Old 'myNonMappedError' is not remained" - when (anyThrows @(NumericErrorWrapper 1 (CustomError "myNonMappedError"))) $ - assertFailure "'myNonMappedError' appears mapped in the result" - ] diff --git a/lorentz-test/Test/Lorentz/Expr.hs b/lorentz-test/Test/Lorentz/Expr.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Expr.hs +++ /dev/null @@ -1,45 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - --- | Tests (and examples) on Lorentz' expressions. -module Test.Lorentz.Expr - ( test_Basic - ) where - -import Lorentz - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -test_Basic :: [TestTree] -test_Basic = - [ testCase "Can compare two values" $ - push [mt|a|] |<| push [mt|b|] -$ () - @?= True - - , testCase "Unary operation" $ - unaryExpr neg take -$ (5 :: Natural) - @?= (-5) - - , testCase "Unary operation operator" $ - neg $: neg $: take -$ (5 :: Natural) - @?= 5 - - , testCase "Can read from stack several times" $ - (take |*| push @Integer 5 |+| take) -$ (5 :: Integer, 10 :: Integer) - @?= 35 - - , testCase "Can access deep elements of the stack" $ - () &- do - push @Integer 5; toNamed #a - push @Natural 2; toNamed #b - push [mt|x|]; toNamed #c - push (); toNamed #d - push @Natural 5 |*| dupL #a |+| push @Natural 8 |*| dupL #b - dip $ do drop; drop; drop; drop; drop - @?= 41 - ] diff --git a/lorentz-test/Test/Lorentz/Extensible.hs b/lorentz-test/Test/Lorentz/Extensible.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Extensible.hs +++ /dev/null @@ -1,66 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Lorentz.Extensible - ( test_Extensible - ) where - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz (toVal) -import Lorentz.Base -import Lorentz.Extensible -import Lorentz.Run.Simple -import Morley.Michelson.Interpret.Pack - -data SumType - = Ctor0 Natural - | Ctor1 - | Ctor2 (Integer, Integer) - deriving stock (Generic, Eq, Show) - -values :: [SumType] -values = - [ Ctor0 42 - , Ctor1 - , Ctor2 (-100, 500) - ] - -test_Extensible :: [TestTree] -test_Extensible = - [ testCase "toExtVal conversion" $ do - fmap toExtVal values @?= - [ Extensible (0, packValue' $ toVal @Natural 42) - , Extensible (1, packValue' $ toVal ()) - , Extensible (2, packValue' $ toVal ints) - ] - , testCase "fromExtVal conversion" $ do - let extValues = [ Extensible (0, packValue' $ toVal @Natural 42) - , Extensible (1, packValue' $ toVal ()) - , Extensible (2, packValue' $ toVal ints) - ] - fmap fromExtVal extValues @?= fmap Right values - , testCase "fromExtVal failure" $ do - let invalidCtor = Extensible (3, packValue' $ toVal ()) - let invalidArg = Extensible (2, packValue' $ toVal ()) - fromExtVal @SumType invalidCtor - @?= Left (ConstructorIndexNotFound 3) - fromExtVal @SumType invalidArg - @?= Left ArgumentUnpackFailed - , testCase "wrapExt" $ do - wrapCode -$? ints @?= (Right $ Extensible (2, packValue' $ toVal ints)) - , testCase "Roundtrip" $ do - fmap roundtrip values @?= fmap Right values - ] - -ints :: (Integer, Integer) -ints = (-100, 500) - -wrapCode :: '[(Integer, Integer)] :-> '[Extensible SumType] -wrapCode = wrapExt #cCtor2 - -roundtrip :: (ExtVal value) => value -> Either ExtConversionError value -roundtrip value = - fromExtVal $ toExtVal value diff --git a/lorentz-test/Test/Lorentz/Instr/MapOption.hs b/lorentz-test/Test/Lorentz/Instr/MapOption.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Instr/MapOption.hs +++ /dev/null @@ -1,46 +0,0 @@ --- 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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Interpreter.hs +++ /dev/null @@ -1,156 +0,0 @@ --- 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 - ) where - -import System.FilePath (()) -import Test.Tasty (TestTree, testGroup) - -import Lorentz (EpdPlain, ParameterHasEntrypoints(..), toAddress) -import Morley.Michelson.Text -import Morley.Michelson.Typed (IsoValue(..)) -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) - -data Self1Parameter - = Self11 Integer - | Self12 () - deriving stock Generic - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints Contract1Parameter where - type ParameterEntrypointsDerivation Contract1Parameter = EpdPlain - -instance ParameterHasEntrypoints Self1Parameter where - type ParameterEntrypointsDerivation Self1Parameter = EpdPlain - -test_Entry_points_lookup :: IO [TestTree] -test_Entry_points_lookup = - testTreesWithTypedContract (dir "call1.mtz") $ \call1 -> - testTreesWithTypedContract (dir "call2.mtz") $ \call2 -> - testTreesWithTypedContract (dir "call3.mtz") $ \call3 -> - testTreesWithTypedContract (dir "call4.mtz") $ \call4 -> - testTreesWithTypedContract (dir "call5.mtz") $ \call5 -> - testTreesWithTypedContract (dir "call6.mtz") $ \call6 -> - testTreesWithTypedContract (dir "call7.mtz") $ \call7 -> - pure - [ testGroup "Calling contract without default entrypoint" - [ testScenarioOnEmulator "Calling default entrypoint refers to the root" $ - myScenario call1 simpleContract id - , testScenarioOnEmulator "Calling some entrypoint refers this entrypoint" $ - myScenario call7 simpleContract id - ] - , testGroup "Calling contract with default entrypoint" - [ testScenarioOnEmulator "Calling default entrypoint works" $ - myScenario call2 defaultEPContract id - ] - , testGroup "Common failures" - [ testScenarioOnEmulator "Fails on type mismatch" $ - myScenario call1 defaultEPContract $ expectFailedWith () - , testScenarioOnEmulator "Fails on entrypoint not found" $ - myScenario call3 simpleContract $ expectFailedWith () - ] - , testGroup "Referring entrypoints groups" - [ testScenarioOnEmulator "Can refer entrypoint group" $ - myScenario call4 complexContract id - , testScenarioOnEmulator "Works with annotations" $ - myScenario call5 complexContract id - , testScenarioOnEmulator "Does not work on annotations mismatch in 'contract' type argument" $ - myScenario call6 complexContract $ expectFailedWith () - ] - ] - where - myScenario = scenario ... myScenario' - myScenario' - :: MonadCleveland caps m - => T.Contract 'T.TAddress 'T.TUnit - -> U.Contract - -> (m () -> m ()) - -> m () - myScenario' caller callee validator = do - hcallee <- originateUntypedSimple "callee" U.ValueUnit callee - hcaller <- originateTypedSimple @Address @_ @() "caller" () caller - validator $ transfer $ TransferData - { tdTo = hcaller - , tdEntrypoint = U.DefEpName - , tdParameter = hcallee - , tdAmount = 100 - } - - dummyCode = U.PrimEx <$> - [ U.CDR U.noAnn U.noAnn - , U.NIL U.noAnn U.noAnn (U.Ty U.TOperation U.noAnn) - , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn - ] - - dummyContract ty = U.Contract (par ty) storageTy dummyCode U.PSC [] - simpleContract = dummyContract contractSimpleTy - defaultEPContract = dummyContract contractWithDefTy - complexContract = dummyContract contractComplexTy - - dir = entrypointsDir - par ty = U.ParameterType ty U.noAnn - storageTy = U.Ty U.TUnit U.noAnn - contractSimpleTy = - U.Ty (U.TOr "a" "b" (U.Ty U.TInt U.noAnn) (U.Ty U.TNat U.noAnn)) - U.noAnn - contractComplexTy = - U.Ty (U.TOr "s" "t" (U.Ty U.TString U.noAnn) contractSimpleTy) - U.noAnn - contractWithDefTy = - U.Ty (U.TOr "a" "default" (U.Ty U.TNat U.noAnn) (U.Ty U.TString U.noAnn)) - U.noAnn - -test_Entry_points_calling :: IO [TestTree] -test_Entry_points_calling = - pure - [ testScenario "Calling some entrypoint in CONTRACT" $ scenario do - call1 <- importContract @Address @_ @() $ dir "call1.mtz" - callerRef <- originateSimple "caller" () call1 - - contract1 <- runIO $ importContractExt @Contract1Parameter @_ @() $ dir "contract1.mtz" - targetRef <- originateSimple "target" 0 contract1 - - transfer TransferData - { tdTo = callerRef - , tdAmount = 1 - , tdEntrypoint = T.DefEpName - , tdParameter = toAddress targetRef - } - - getStorage @Integer targetRef @@== 5 - - , testScenario "Calling some entrypoint in SELF" $ scenario do - self1 <- runIO $ importContractExt @Self1Parameter @_ @() $ dir "self1.mtz" - contractRef <- originateSimple "self" 0 self1 - - transfer TransferData - { tdTo = contractRef - , tdAmount = 1 - , tdEntrypoint = T.DefEpName - , tdParameter = Right @Integer () - } - - getStorage @Integer contractRef @@== 5 - ] - where - dir = entrypointsDir - -entrypointsDir :: FilePath -entrypointsDir = ".." ".." "contracts" "entrypoints" diff --git a/lorentz-test/Test/Lorentz/Macro.hs b/lorentz-test/Test/Lorentz/Macro.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Macro.hs +++ /dev/null @@ -1,505 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz macros. --- --- They test logic of macros and type-level logic. Also they serve as --- examples of using complex macros (e. g. parameterized with --- type-level numbers) - -module Test.Lorentz.Macro - ( 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 Prelude hiding (drop, swap) - -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 - duupX @2 @?= duupX2 - duupX @3 @?= duupX3 - where - duupX1 :: [Bool, Integer, (), Bool] :-> [Bool, Bool, Integer, (), Bool] - duupX1 = dupN @1 - - duupX2 :: [Bool, Integer, (), Bool] :-> [Integer, Bool, Integer, (), Bool] - duupX2 = dupN @2 - - 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 - replaceN @2 @?= replaceN2 - replaceN @3 @?= replaceN3 - where - replaceN2 :: [(), Integer, (), Bool] :-> [Integer, (), Bool] - replaceN2 = dipN @2 drop # dug @1 - - replaceN3 :: [Bool, Integer, (), Bool] :-> [Integer, (), Bool] - replaceN3 = dipN @3 drop # dug @2 - -unit_updateN :: Assertion -unit_updateN = do - updateN @1 cons @?= updateN1 - updateN @2 cons @?= updateN2 - updateN @3 cons @?= updateN3 - where - updateN1 :: [Bool, [Bool], Integer, ()] :-> [[Bool], Integer, ()] - updateN1 = cons - - updateN2 :: [Bool, Integer, [Bool], ()] :-> [Integer, [Bool], ()] - updateN2 = swap # dip cons - - 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 = - [ testCase "Two arguments lambda" $ - let lam :: [Integer, Integer] :-> [(), Integer] - lam = add # unit - code = push 3 # push lam # execute # drop @() - in code -$? 5 @?= Right 8 - - , testCase "Zero arguments lambda" $ - let lam :: '[] :-> '[Integer] - lam = push 5 - code = drop # push lam # execute - in code -$? (0 :: Natural) @?= Right 5 - ] - -test_applicate :: [TestTree] -test_applicate = - [ testCase "Simple partial application" $ - let lam :: '[Integer, Integer] :-> '[Integer] - lam = add - code = dip (push lam) # applicate # push 1 # exec - in code -$? 5 @?= Right 6 - ] diff --git a/lorentz-test/Test/Lorentz/MorleyLogs.hs b/lorentz-test/Test/Lorentz/MorleyLogs.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/MorleyLogs.hs +++ /dev/null @@ -1,123 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for checking MorleyLogs processing. -module Test.Lorentz.MorleyLogs - ( test_MorleyLogs - ) where - -import Prelude hiding (drop, swap) -import Test.Tasty (TestTree, testGroup) - -import Lorentz hiding (assert) -import Morley.Michelson.Interpret (MorleyLogs(..)) -import Morley.Michelson.Untyped (Contract) -import Morley.Michelson.Untyped.Value (Value'(..)) -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 -> - pure - [ testGroup "Checking MorleyLogs processing" - [ testScenarioOnEmulator "Calling contract with single log" $ scenarioEmulated do - idAddr <- originateS - logsInfo <- getMorleyLogs_ $ do - call idAddr CallDefault () - call idAddr CallDefault () - logsForAddress idAddr logsInfo @== fmap MorleyLogs [["log"], ["log"]] - collectLogs logsInfo @== MorleyLogs ["log", "log"] - - , testScenarioOnEmulator "Calling several contracts with and without logs" $ scenarioEmulated do - idAddrW <- originateW withoutLogs - idAddrS <- originateS - idAddrM <- originateM - logsInfo <- getMorleyLogs_ $ do - call idAddrW CallDefault () - call idAddrS CallDefault () - call idAddrM CallDefault () - logsForAddress idAddrW logsInfo @== fmap MorleyLogs [[]] - logsForAddress idAddrS logsInfo @== fmap MorleyLogs [["log"]] - logsForAddress idAddrM logsInfo @== fmap MorleyLogs [["log1", "log2", "log3"]] - collectLogs logsInfo @== MorleyLogs ["log", "log1", "log2", "log3"] - - , testScenarioOnEmulator "Calling several contracts to check the logging order" $ scenarioEmulated do - idAddrS <- originateS - idAddrM <- originateM - logsInfo <- getMorleyLogs_ $ do - call idAddrS CallDefault () - call idAddrM CallDefault () - call idAddrS CallDefault () - logsForAddress idAddrM logsInfo @== fmap MorleyLogs [["log1", "log2", "log3"]] - logsForAddress idAddrS logsInfo @== fmap MorleyLogs [["log"], ["log"]] - collectLogs logsInfo @== MorleyLogs ["log", "log1", "log2", "log3", "log"] - - , testScenarioOnEmulator "Calling contracts in parallel with branchout" $ scenarioEmulated do - branchout - [ ("1", do - idAddr <- originateS - logsInfo <- getMorleyLogs_ $ - call idAddr CallDefault () - logsForAddress idAddr logsInfo @== fmap MorleyLogs [["log"]]) - - , ("2", do - idAddr <- originateS - logsInfo <- getMorleyLogs_ $ - call idAddr CallDefault () - collectLogs logsInfo @== MorleyLogs ["log"]) - ] - -- This test checks the behavior of MorleyLogs when one - -- contract is called by another contract. In this case contracts contain only - -- logs produced by themselves. - , testScenarioOnEmulator "Calling a contract inside another contract" $ scenarioEmulated do - logsInfo <- getMorleyLogs_ $ do - caller <- originateSimple "caller" () callerContract - target <- originateSimple "target" () targetContract - call caller CallDefault (toContractRef target) - collectLogs logsInfo @== - MorleyLogs ["Caller contract called", "Target contract called with 5"] - ] - ] - where - originateContract - :: forall caps m. MonadCleveland caps m - => AliasHint - -> Morley.Michelson.Untyped.Contract - -> m (TAddress () ()) - originateContract name c = do - addr <- originateUntyped $ - UntypedOriginateData name 100 ValueUnit c - return $ toTAddress addr - - originateW - :: forall caps m. MonadCleveland caps m - => Morley.Michelson.Untyped.Contract - -> m (TAddress () ()) - originateW = originateContract "without 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 $ - car # - printComment "Caller contract called" # - (push zeroMutez # push 5 # transferTokens |:| nil) # - unit # swap # pair - - targetContract :: Lorentz.Contract Integer () () - targetContract = defaultContract $ - car # - printComment ("Target contract called with " <> stackRef @0) # - drop # - unit # nil # pair diff --git a/lorentz-test/Test/Lorentz/Optimizer.hs b/lorentz-test/Test/Lorentz/Optimizer.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Optimizer.hs +++ /dev/null @@ -1,47 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for optimization of Lorentz-specific instruction sequences. -module Test.Lorentz.Optimizer - ( unit_eq0 - , unit_non - , unit_stGet - ) where - -import Lorentz ((#), (:->)) -import Lorentz qualified as L -import Morley.Michelson.Optimizer (optimize) -import Morley.Michelson.Typed.Util (linearizeLeft) -import Test.HUnit (Assertion, (@?=)) - --- | Check whether code on left hand side optimizes to the code on --- the right hand side. -infix 1 ->?= -(->?=) :: i :-> o -> i :-> o -> Assertion -(L.iAnyCode -> pre) ->?= (L.iAnyCode -> post) = - linearizeLeft (optimize pre) @?= linearizeLeft post - -unit_eq0 :: Assertion -unit_eq0 = - L.push @Integer 0 # L.eq ->?= L.eq0 - -unit_non :: Assertion -unit_non = - L.non @Integer 0 ->?= L.nonZero - --- TODO [#300]: this test fails because the optimizer seemingly doesn't revisit the --- optimized instruction after one rule application, e.g. here the adjacent DIPs --- rule is applied, but not the 'isSome after if' one. --- unit_stUpdate :: Assertion --- unit_stUpdate = --- L.dip (L.if_ (L.push (Just @Integer 0)) (L.push Nothing)) # L.stUpdate L.this ->?= update' --- where --- update' :: (Integer : Bool : Set Integer : s) :-> (Set Integer : s) --- update' = L.update - -unit_stGet :: Assertion -unit_stGet = - L.stGet L.this # L.isSome ->?= mem' - where - mem' :: (Integer : Set Integer : s) :-> (Bool : s) - mem' = L.mem diff --git a/lorentz-test/Test/Lorentz/Pack.hs b/lorentz-test/Test/Lorentz/Pack.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Pack.hs +++ /dev/null @@ -1,48 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz packing/unpacking - -module Test.Lorentz.Pack - ( 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) - -import Morley.Michelson.Typed.Instr (Instr(..)) -import Morley.Michelson.Typed.Util (DfsSettings(..), dfsFoldInstr) - -test_lambda_roundtrip :: [TestTree] -test_lambda_roundtrip = - [ testCase "Packing and then unpacking a Lambda does not add empty annotations" $ - lambdaRoundtripWithoutNotes lam - ] - where - lam :: Lambda () () - lam = push @Natural 5 # drop - --- | Checks that packing and unpacking a lambda made of instructions without --- Annotations will produce the same lambda, still without annotations. -lambdaRoundtripWithoutNotes - :: forall i o. NiceUnpackedValue (Lambda i o) - => Lambda i o - -> Assertion -lambdaRoundtripWithoutNotes l = case lUnpackValueRaw @(Lambda i o) $ lPackValueRaw l of - Left err -> assertFailure $ "Unpacking error: " <> pretty err - Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of - [] -> ul @?= l - notes -> assertFailure $ "Lambda has annotations: " <> pretty notes - where - dfsSettings = def { dsGoToValues = True} - - instrNotes :: Instr inp out -> [Text] - instrNotes = \case - InstrWithNotes _ n _ -> [Debug.show n] - _ -> [] diff --git a/lorentz-test/Test/Lorentz/Print.hs b/lorentz-test/Test/Lorentz/Print.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Print.hs +++ /dev/null @@ -1,119 +0,0 @@ --- 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 Lorentz qualified as L -import Prelude hiding (drop, swap) - -import Test.HUnit (Assertion, assertEqual, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Morley.Michelson.Printer.Util (buildRenderDoc) -import Morley.Michelson.Typed hiding (Contract, ContractCode, defaultContract) -import Morley.Michelson.Untyped (contractParameter) - -data MyEntrypoints1 - = Do1 Integer - | Do2 (Integer, Integer) - | Do3 - deriving stock Generic - deriving anyclass IsoValue - -instance ParameterHasEntrypoints MyEntrypoints1 where - type ParameterEntrypointsDerivation MyEntrypoints1 = EpdPlain - -contract :: Contract MyEntrypoints1 () () -contract = defaultContract $ - drop # unit # nil # pair - -test_Print_parameter_annotations :: [TestTree] -test_Print_parameter_annotations = - [ testCase "Simple parameter" $ - let typedContract = toMichelsonContract contract - untypedContract = convertContract typedContract - in buildRenderDoc (contractParameter untypedContract) - @?= - "or (int %do1) (or (pair %do2 int int) (unit %do3))" - ] - -test_Print_lambda :: [TestTree] -test_Print_lambda = - [ testCase "Prints correct lambda instruction" $ - let - code :: '[Integer] :-> '[('[Integer] :-> '[()])] - code = drop # lambda (drop # unit) - in printLorentzValue True code - @?= - "{ DROP;LAMBDA int unit { DROP;UNIT } }" - ] - -data TestParam - = TestCon1 ("a" :! Natural, "b" :! Natural) - | TestCon2 Bool - deriving stock Generic - deriving anyclass IsoValue - -instance ParameterHasEntrypoints TestParam where - type ParameterEntrypointsDerivation TestParam = EpdRecursive - -unit_Erase_annotations :: Assertion -unit_Erase_annotations = - let - myContract :: Contract TestParam Bool () - myContract = defaultContract $ - 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) (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, 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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Product.hs +++ /dev/null @@ -1,94 +0,0 @@ --- 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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/ReferencedByName.hs +++ /dev/null @@ -1,34 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Lorentz.NameReferenced' module. --- --- They test logic of macros in that module and type-level logic, --- and serve as examples of their use. - -module Test.Lorentz.ReferencedByName - ( test_dupL - ) where - -import Lorentz -import Prelude hiding (drop, swap) - -import Test.HUnit (Assertion, (@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Morley.Michelson.Typed - --- | Compare instructions on their untyped representation. --- --- Necessary to exclude @Nop@s. -(@?~=) :: a :-> b -> a :-> b -> Assertion -(@?~=) = (@?=) `on` (instrToOps . iAnyCode) -infix 1 @?~= - -test_dupL :: [TestTree] -test_dupL = - [ testCase "Duplicating third element" $ - stackType @[(), "a" :! Integer, "b" :! Natural] # dupL #b - @?~= dupN @3 # fromNamed #b - ] diff --git a/lorentz-test/Test/Lorentz/Storage.hs b/lorentz-test/Test/Lorentz/Storage.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Storage.hs +++ /dev/null @@ -1,195 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on Lorentz storage annotation parsing. - -module Test.Lorentz.Storage - ( test_FieldAnnotations - , test_TypeAnnotations - ) where - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Lorentz ((:!)) -import Lorentz qualified as L -import Lorentz.Annotation (HasAnnotation) -import Lorentz.Run hiding (Contract(..)) -import Lorentz.Value -import Morley.Michelson.Typed (Contract, Contract'(..)) -import Morley.Michelson.Untyped.Annotation -import Test.Cleveland.Instances () - -import Test.Util.Annotation - ----------------------------------------------------------------------------- --- Storage declarations ----------------------------------------------------------------------------- - -data MyParams = MyParams - { p1 :: Natural - , p2 :: Address - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data UnitStorage = UnitStorage - { unit :: () - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage1 = MyStorage1 - { st1 :: () - , st2 :: () - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage2 = MyStorage2 - { st3 :: Maybe Address - , st4 :: (Natural, Natural) - , st5 :: MyParams - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage2r = MyStorage2r - { st3r :: Maybe Address - , st4r :: (Natural, Natural) - , st5r :: MyParams - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage3 = MyStorage3 - { st6 :: ("tuplearg" :! ("TL" :! Address, "TR" :! Integer), "boolarg" :! Bool) - , st7 :: ("integerarg" :! Natural, "boolarg" :! Bool) - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage4 = MyStorage4 - { st8 :: ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ()) - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage5 = MyStorage5 - { st9 :: ("maybearg" :! Maybe ("maybeinner" :! Natural)) - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage6 = MyStorage6 - { st10 :: ("lambdaarg" :! L.Lambda Natural Natural) - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -data MyStorage7 = MyStorage7 - { st11 :: ("listarg" :! [("balance" :! Natural , "address" :! L.Address)]) - } deriving stock Generic - deriving anyclass (IsoValue, HasAnnotation) - -dummyContract :: forall storage. L.NiceStorageFull storage => L.Contract () storage () -dummyContract = defaultContract L.fakeCoerce - ----------------------------------------------------------------------------- --- Field annotations ----------------------------------------------------------------------------- - -test_FieldAnnotations :: [TestTree] -test_FieldAnnotations = - [ - testCase "Simple storage" $ do - extractAnnotation @MyStorage1 - @?= - FANodePair - "st1" FALeaf - "st2" FALeaf - - , testCase "Complex storage" $ do - extractAnnotation @MyStorage2 - @?= - FANodePair - "st3" - FALeaf - noAnn - (FANodePair - "st4" FALeaf - "st5" - (FANodePair - "p1" FALeaf - "p2" FALeaf)) - - , testCase "Complex parameter recursive" $ do - extractAnnotation @MyStorage2r - @?= - FANodePair - "st3r" - FALeaf - noAnn - (FANodePair - "st4r" - FALeaf - "st5r" - (FANodePair - "p1" FALeaf - "p2" FALeaf)) - ] - where - storageAnnTree :: Contract cp st -> FieldAnnTree st - storageAnnTree = extractFieldAnnTree . cStoreNotes - - extractAnnotation :: forall st. L.NiceStorageFull st => FieldAnnTree (ToT st) - extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st) - -test_TypeAnnotations :: [TestTree] -test_TypeAnnotations = - [ testCase "Address primitive storage with no annotations" $ - extractAnnotation @Address - @?= - TALeaf noAnn - - , testCase "Named type annotation" $ - extractAnnotation @MyStorage3 - @?= - TANodePair noAnn - (TANodePair noAnn - (TANodePair "tuplearg" - (TALeaf "TL") - (TALeaf "TR")) - (TALeaf "boolarg")) - (TANodePair noAnn - (TALeaf "integerarg") - (TALeaf "boolarg")) - - , testCase "BigMap type annotation" $ - extractAnnotation @MyStorage4 - @?= - TANodeLambda "bigmaparg" - (TANodeBigMap noAnn - (TALeaf noAnn) - (TANodePair noAnn - (TALeaf "balance") - (TALeaf "address"))) - (TALeaf noAnn) - - , testCase "Maybe type annotation" $ - extractAnnotation @MyStorage5 - @?= - TANodeOption "maybearg" (TALeaf "maybeinner") - - , testCase "Lambda type annotation" $ - extractAnnotation @MyStorage6 - @?= - TANodeLambda "lambdaarg" (TALeaf noAnn) (TALeaf noAnn) - - , testCase "List type annotation" $ - extractAnnotation @MyStorage7 - @?= - TANodeList "listarg" - (TANodePair noAnn - (TALeaf "balance") - (TALeaf "address")) - - ] - where - storageAnnTree :: Contract cp st -> TypeAnnTree st - storageAnnTree = extractTypeAnnTree . cStoreNotes - - 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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs +++ /dev/null @@ -1,110 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Lorentz.StoreClass.ComplexRefs - ( test_Nested - , test_Direct - , test_stToFieldNamed - ) where - -import Prelude hiding (drop, swap) - -import Control.Lens (at) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Lorentz.Run.Simple -import Lorentz.StoreClass -import Lorentz.StoreClass.Extra qualified as E -import Lorentz.Value -import Morley.Util.Lens -import Morley.Util.Named -import Test.Cleveland.Instances () - -data Storage = Storage - { sField1 :: SubStorage - } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue) - -data SubStorage = SubStorage - { ssField1 :: Group - } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue) - -data Group = Group - { gField :: Integer - , gSubmap :: Map MText Natural - } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue) - -makeLensesWith postfixLFields ''Storage -makeLensesWith postfixLFields ''SubStorage -makeLensesWith postfixLFields ''Group - -initStorage :: Storage -initStorage = Storage - { sField1 = SubStorage - { ssField1 = Group - { gField = 3 - , gSubmap = one ("a", 5) - } - } - } - -test_Nested :: [TestTree] -test_Nested = - [ testCase "Deep field access" $ - initStorage - &- stToField (#sField1 :-| #ssField1 :-| #gField) - @?= 3 - - , testCase "Deep map elem access" $ - ("a", initStorage) - &- stGet (#sField1 :-| #ssField1 :-| #gSubmap) - @?= Just 5 - - , testCase "Deep field update" $ - (99, initStorage) - &- stSetField (#sField1 :-| #ssField1 :-| #gField) - @?= (initStorage & sField1L . ssField1L . gFieldL .~ 99) - - , testCase "Deep map elem update" $ - ("b", (Just 50, initStorage)) - &- stUpdate (#sField1 :-| #ssField1 :-| #gSubmap) - @?= (initStorage & sField1L . ssField1L . gSubmapL . at "b" .~ Just 50) - - , testCase "Intermediate piece access" $ - initStorage - &- stToField (#sField1 :-| #ssField1) - @?= (initStorage & sField1 & ssField1) - ] - -test_Direct :: [TestTree] -test_Direct = - [ testCase "Direct access to field" $ - (5 :: Natural) &- stToField this - @?= 5 - - , testCase "Access using stNested" $ - initStorage - &- stToField (stNested #sField1 #ssField1 #gField) - @?= 3 - - , testCase "Access using dot operator" $ - initStorage - &- stToField (#sField1 E.. #ssField1 E.. #gField) - @?= 3 - ] - -test_stToFieldNamed :: [TestTree] -test_stToFieldNamed = - [ testCase "Symbolic reference" $ - initStorage - &- stToFieldNamed #sField1 - @?= #sField1 :! sField1 initStorage - - , testCase "Nested field reference" $ - initStorage - &- stToFieldNamed (#sField1 :-| #ssField1 :-| #gField) - @?= #gField :! 3 - ] diff --git a/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs b/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs +++ /dev/null @@ -1,141 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Lorentz.StoreClass.SetSubmap - ( test_Simple_set - ) where - -import Prelude hiding (drop, swap) - -import Data.Set qualified as S -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) - -import Lorentz qualified as L -import Lorentz.Base -import Lorentz.Constraints -import Lorentz.Run.Simple -import Lorentz.StoreClass -import Lorentz.Value -import Test.Cleveland.Instances () - ----------------------------------------------------------------------------- --- Types ----------------------------------------------------------------------------- - -data Storage = Storage - { x :: Set MText - } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue) - -emptyStorage :: Storage -emptyStorage = Storage mempty - -mkStorage :: [MText] -> Storage -mkStorage = Storage . S.fromList - ----------------------------------------------------------------------------- --- Tests ----------------------------------------------------------------------------- - -type DeleteInstr = - forall mname key value store s. - (StoreHasSubmap store mname key value, KnownValue value) - => FieldSymRef mname -> key : store : s :-> store : s - -testCaseDelete :: (DeleteInstr -> Assertion) -> TestTree -testCaseDelete mkSuite = - testGroup "delete" - [ testCase "setDelete" $ mkSuite stDelete - ] - -type InsertInstr = - forall mname key value store s. - (StoreHasSubmap store mname key value) - => FieldSymRef mname -> key : value : store : s :-> store : s - -testCaseInsert :: (InsertInstr -> Assertion) -> TestTree -testCaseInsert mkSuite = - testGroup "insert" - [ testCase "setInsert" $ mkSuite stInsert - ] - -key1, key2 :: MText -key1 = "a" -key2 = "b" - -test_Simple_set :: [TestTree] -test_Simple_set = - let l = #x in - [ testGroup "Empty storage" - - [ testCase "mem" $ - emptyStorage - &- L.push key1 # stMem l - @?= False - - , testCase "get" $ - emptyStorage - &- L.push key1 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - emptyStorage - &- L.push key1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - emptyStorage - &- L.push () # L.push key1 # insert l - @?= mkStorage [key1] - ] - - , testGroup "Storage with some values - checking them" - - [ testCase "mem" $ - mkStorage [key1] - &- L.push key1 # stMem l - @?= True - - , testCase "get" $ - mkStorage [key1] - &- L.push key1 # stGet l - @?= Just () - - , testCaseDelete $ \delete -> - mkStorage [key1] - &- L.push key1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - mkStorage [key1] - &- L.push () # L.push key1 # insert l - @?= mkStorage [key1] - - ] - - , testGroup "Storage with some values - checking others" - - [ testCase "mem" $ - mkStorage [key1] - &- L.push key2 # stMem l - @?= False - - , testCase "get" $ - mkStorage [key1] - &- L.push key2 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - mkStorage [key1] - &- L.push key2 # delete l - @?= mkStorage [key1] - - , testCaseInsert $ \insert -> - mkStorage [key1] - &- L.push () # L.push key2 # insert l - @?= mkStorage [key1, key2] - - ] - - ] diff --git a/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs b/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs +++ /dev/null @@ -1,158 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Lorentz.StoreClass.StorageEntrypoints - ( test_Storage_entrypoints - ) where - -import Prelude hiding (drop, swap) - -import Data.Constraint (Dict(..), (:-)(Sub)) -import Test.Tasty (TestTree) - -import Lorentz.ADT -import Lorentz.Annotation (HasAnnotation) -import Lorentz.Base -import Lorentz.Constraints -import Lorentz.Entrypoints -import Lorentz.Entrypoints.Doc -import Lorentz.Instr -import Lorentz.Macro -import Lorentz.Run -import Lorentz.StoreClass -import Lorentz.Value -import Test.Cleveland -import Test.Cleveland.Lorentz - ----------------------------------------------------------------------------- --- Types ----------------------------------------------------------------------------- - -data ParameterEpTest - = AddNat Natural - | SubNat Natural - | GetValue (View_ () Natural) - | SetSubNat (EntrypointLambda Natural Natural) - deriving stock Generic - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints ParameterEpTest where - type ParameterEntrypointsDerivation ParameterEpTest = EpdPlain - -data StorageEpTest = StorageEpTest - { epNats :: EntrypointsField Natural Natural - , storeNat :: Natural - } deriving stock Generic - deriving anyclass IsoValue - deriving anyclass HasAnnotation - -instance StoreHasEntrypoint StorageEpTest "addNat" Natural Natural where - storeEpOps = storeEntrypointOpsADT #epNats #storeNat - -instance StoreHasEntrypoint StorageEpTest "subNat" Natural Natural where - storeEpOps = storeEntrypointOpsADT #epNats #storeNat - -instance StoreHasField StorageEpTest "storeNat" Natural where - storeFieldOps = storeFieldOpsADT - -type StorageIsEpTest store = - ( StorageContains store - [ "addNat" := Natural ::-> Natural - , "subNat" := Natural ::-> Natural - , "storeNat" := Natural - ] - , Dupable store - ) - ----------------------------------------------------------------------------- --- Impl ----------------------------------------------------------------------------- - -addNat :: EntrypointLambda Natural Natural -addNat = unpair # add # nil # pair - -subNat :: EntrypointLambda Natural Natural -subNat = unpair # swap # sub # isNat # ifSome nop (push 0) # nil # pair - -mkStorageEpTestFull :: Natural -> StorageEpTest -mkStorageEpTestFull n = StorageEpTest - { epNats = mkStoreEp #addNat addNat <> mkStoreEp #subNat subNat - , storeNat = n - } - -mkStorageEpTestPart :: Natural -> StorageEpTest -mkStorageEpTestPart n = StorageEpTest - { epNats = mkStoreEp #addNat addNat - , storeNat = n - } - -contractEpTest :: StorageIsEpTest store => ContractCode ParameterEpTest store -contractEpTest = unpair # entryCaseSimple @ParameterEpTest - ( #cAddNat /-> stEntrypoint #addNat - , #cSubNat /-> stEntrypoint #subNat - , #cGetValue /-> view_ (drop @() # stToField #storeNat) - , #cSetSubNat /-> stSetEpLambda #subNat # nil # pair - ) - ----------------------------------------------------------------------------- --- Tests ----------------------------------------------------------------------------- - -originateEpContract - :: MonadCleveland caps m - => StorageEpTest - -> m (ContractHandle ParameterEpTest StorageEpTest ()) -originateEpContract st = originate $ OriginateData "StEps" 0 st (defaultContract contractEpTest) - -test_Storage_entrypoints :: [TestTree] -test_Storage_entrypoints = - [ testScenario "Executes both entrypoints correctly when set at origination" $ scenario do - testCon <- originateEpContract $ mkStorageEpTestFull 10 - consumer <- originateSimple "consumer" def contractConsumer - - call testCon CallDefault $ GetValue (mkView_ () consumer) - call testCon CallDefault $ AddNat 10 - call testCon CallDefault $ GetValue (mkView_ () consumer) - call testCon CallDefault $ SubNat 5 - call testCon CallDefault $ GetValue (mkView_ () consumer) - - getStorage consumer @@== [15, 20, 10] - - , testScenario "Cannot set entrypoint that was set at origination" $ scenario do - testCon <- originateEpContract $ mkStorageEpTestFull 10 - - expectFailedWith [mt|Storage entrypoint already set: subNat|] $ - call testCon CallDefault (SetSubNat subNat) - - , testScenario "Cannot set entrypoint twice" $ scenario do - testCon <- originateEpContract $ mkStorageEpTestPart 10 - - call testCon CallDefault $ SetSubNat subNat - expectFailedWith [mt|Storage entrypoint already set: subNat|] $ - call testCon CallDefault (SetSubNat subNat) - - , testScenario "Executes correctly entrypoint set after origination" $ scenario do - testCon <- originateEpContract $ mkStorageEpTestPart 10 - consumer <- originateSimple "consumer" def contractConsumer - - call testCon CallDefault $ GetValue (mkView_ () consumer) - call testCon CallDefault $ AddNat 5 - call testCon CallDefault $ GetValue (mkView_ () consumer) - - call testCon CallDefault $ SetSubNat subNat - call testCon CallDefault $ SubNat 20 - call testCon CallDefault $ GetValue (mkView_ () consumer) - - getStorage consumer @@== [0, 15, 10] - ] - ----------------------------------------------------------------------------- --- Tests on conveniences ----------------------------------------------------------------------------- - -type StorageC store meta = StorageContains store - '[ "field" := Identity meta - ] - -_storeFieldConstraintInterpretedCorrectly :: StorageC store meta :- StoreHasField store "field" meta -_storeFieldConstraintInterpretedCorrectly = Sub Dict diff --git a/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs b/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs +++ /dev/null @@ -1,290 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Lorentz.StoreClass.SubmapZoom - ( test_Simple_part_of_value - , test_Part_of_value_with_nested_map - , test_Different_parts_of_value_interaction - ) where - -import Prelude hiding (drop, swap) - -import Data.Map qualified as M -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) - -import Lorentz qualified as L -import Lorentz.Base -import Lorentz.Constraints -import Lorentz.Iso -import Lorentz.Run.Simple -import Lorentz.StoreClass -import Lorentz.Value -import Morley.Util.Named -import Test.Cleveland.Instances () - ----------------------------------------------------------------------------- --- Types ----------------------------------------------------------------------------- - -type MapValue = ("x" :! Natural, "y" :! Map MText Integer) - -data Storage = Storage - { all :: BigMap MText MapValue - } deriving stock (Eq, Show, Generic) - deriving anyclass (IsoValue) - -instance StoreHasSubmap Storage (FieldNickname "x") MText Natural where - storeSubmapOps = - storeSubmapOpsReferTo #x $ - zoomStoreSubmapOps #all nonDefIso nonDefIso storeSubmapOps storeFieldOpsADT - -instance StoreHasSubmap Storage (FieldNickname "y") (MText, MText) Integer where - storeSubmapOps = - storeSubmapOpsReferTo #y $ - sequenceStoreSubmapOps #all nonDefIso storeSubmapOps storeSubmapOps - -emptyStorage :: Storage -emptyStorage = Storage mempty - -mkStorage :: [(MText, (Natural, [(MText, Integer)]))] -> Storage -mkStorage entries = - Storage $ mkBigMap - [ (k, (#x :! v1, #y :! M.fromList v2)) - | (k, (v1, v2)) <- entries - ] - ----------------------------------------------------------------------------- --- Tests ----------------------------------------------------------------------------- - -type DeleteInstr = - forall mname key value store s. - (StoreHasSubmap store (FieldNickname mname) key value, KnownValue value) - => FieldRef (FieldNickname mname) -> key : store : s :-> store : s - -testCaseDelete :: (DeleteInstr -> Assertion) -> TestTree -testCaseDelete mkSuite = - testGroup "delete" - [ testCase "normal" $ mkSuite stDelete - , testCase "via update" $ mkSuite (\l -> L.dip L.none # stUpdate l) - ] - -type InsertInstr = - forall mname key value store s. - (StoreHasSubmap store (FieldNickname mname) key value) - => FieldRef (FieldNickname mname) -> key : value : store : s :-> store : s - -testCaseInsert :: (InsertInstr -> Assertion) -> TestTree -testCaseInsert mkSuite = - testGroup "insert" - [ testCase "normal" $ mkSuite stInsert - , testCase "via update" $ mkSuite (\l -> L.dip L.some # stUpdate l) - ] - -key1, key2 :: MText -key1 = "a" -key2 = "b" - -dkey1 :: (MText, MText) -dkey1 = (key1, key1) - -test_Simple_part_of_value :: [TestTree] -test_Simple_part_of_value = - let l = stNickname #x in - [ testGroup "Empty storage" - - [ testCase "mem" $ - emptyStorage - &- L.push key1 # stMem l - @?= False - - , testCase "get" $ - emptyStorage - &- L.push key1 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - emptyStorage - &- L.push key1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - emptyStorage - &- L.push 1 # L.push key1 # insert l - @?= mkStorage [(key1, (1, []))] - ] - - , testGroup "Storage with some values - checking them" - - [ testCase "mem" $ - mkStorage [(key1, (1, []))] - &- L.push key1 # stMem l - @?= True - - , testCase "mem for def value" $ - mkStorage [(key1, (0, []))] - &- L.push key1 # stMem l - @?= False - - , testCase "get" $ - mkStorage [(key1, (1, []))] - &- L.push key1 # stGet l - @?= Just 1 - - , testCase "get for def value" $ - mkStorage [(key1, (0, []))] - &- L.push key1 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - mkStorage [(key1, (1, []))] - &- L.push key1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - mkStorage [(key1, (1, []))] - &- L.push 2 # L.push key1 # insert l - @?= mkStorage [(key1, (2, []))] - - ] - - , testGroup "Storage with some values - checking others" - - [ testCase "mem" $ - mkStorage [(key1, (1, []))] - &- L.push key2 # stMem l - @?= False - - , testCase "get" $ - mkStorage [(key1, (1, []))] - &- L.push key2 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - mkStorage [(key1, (1, []))] - &- L.push key2 # delete l - @?= mkStorage [(key1, (1, []))] - - , testCaseInsert $ \insert -> - mkStorage [(key1, (1, []))] - &- L.push 2 # L.push key2 # insert l - @?= mkStorage [(key1, (1, [])), (key2, (2, []))] - - ] - - ] - -test_Part_of_value_with_nested_map :: [TestTree] -test_Part_of_value_with_nested_map = - let l = stNickname #y in - [ testGroup "Empty storage" - - [ testCase "mem" $ - emptyStorage - &- L.push dkey1 # stMem l - @?= False - - , testCase "get" $ - emptyStorage - &- L.push dkey1 # stGet l - @?= Nothing - - , testCaseDelete $ \delete -> - emptyStorage - &- L.push dkey1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - emptyStorage - &- L.push 1 # L.push dkey1 # insert l - @?= mkStorage [(key1, (0, [(key1, 1)]))] - - ] - - , testGroup "Storage with some values - checking them" - - [ testCase "mem" $ - mkStorage [(key1, (0, [(key1, 1)]))] - &- L.push dkey1 # stMem l - @?= True - - , testCase "mem for def value" $ - mkStorage [(key1, (0, [(key1, 0)]))] - &- L.push dkey1 # stMem l - @?= True - - , testCase "get" $ - mkStorage [(key1, (0, [(key1, 1)]))] - &- L.push dkey1 # stGet l - @?= Just 1 - - , testCase "get for def value" $ - mkStorage [(key1, (0, [(key1, 0)]))] - &- L.push dkey1 # stGet l - @?= Just 0 - - , testCaseDelete $ \delete -> - mkStorage [(key1, (0, [(key1, 1)]))] - &- L.push dkey1 # delete l - @?= emptyStorage - - , testCaseInsert $ \insert -> - mkStorage [(key1, (0, [(key1, 1)]))] - &- L.push 2 # L.push dkey1 # insert l - @?= mkStorage [(key1, (0, [(key1, 2)]))] - - ] - - ] - -test_Different_parts_of_value_interaction :: [TestTree] -test_Different_parts_of_value_interaction = - [ testGroup "Deleting the last value" - [ testGroup "Working with simple subvalue" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1)]))] - &- L.push key1 # delete (stNickname #x) - @?= mkStorage [(key1, (0, [(key1, 1)]))] - ] - - , testGroup "Working with nested map" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1)]))] - &- L.push dkey1 # delete (stNickname #y) - @?= mkStorage [(key1, (1, []))] - ] - - ] - - , testGroup "Deleting not the last value" - [ testGroup "Working with simple subvalue 1" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))] - &- L.push key1 # delete (stNickname #x) - @?= mkStorage [(key1, (0, [(key1, 1)])), (key2, (1, []))] - ] - - , testGroup "Working with simple subvalue 2" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))] - &- L.push key2 # delete (stNickname #x) - @?= mkStorage [(key1, (1, [(key1, 1)]))] - ] - - , testGroup "Working with nested map 1" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1)])), (key2, (1, []))] - &- L.push dkey1 # delete (stNickname #y) - @?= mkStorage [(key1, (1, [])), (key2, (1, []))] - ] - - , testGroup "Working with nested map 2" - [ testCaseDelete $ \delete -> - mkStorage [(key1, (1, [(key1, 1), (key2, 1)]))] - &- L.push dkey1 # delete (stNickname #y) - @?= mkStorage [(key1, (1, [(key2, 1)]))] - ] - - ] - ] diff --git a/lorentz-test/Test/Lorentz/Tickets.hs b/lorentz-test/Test/Lorentz/Tickets.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Tickets.hs +++ /dev/null @@ -1,91 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on basic tickets functionality. --- --- Tests on helpers from "Lorentz.Tickets" module lie in a different module. -module Test.Lorentz.Tickets - ( test_Interpreter - ) where - -import Lorentz -import Prelude () - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Tezos.Address -import Morley.Michelson.Interpret (ContractEnv(..)) -import Morley.Michelson.Runtime.Dummy (dummyContractEnv) -import Test.Cleveland.Util - --- | Address of self assigned in tests runs by Lorentz interpreter. -dummySelf :: Address -dummySelf = ceSelf dummyContractEnv - -addr1, addr2 :: Address -addr1 = runGen 100 1 genAddress -addr2 = runGen 100 2 genAddress - -test_Interpreter :: [TestTree] -test_Interpreter = - [ testGroup "TICKET" - [ testCase "Simple case" $ - ticket -$ ([mt|a|], 10) - @?= Ticket - { tTicketer = dummySelf - , tData = [mt|a|] - , tAmount = 10 - } - ] - - , testGroup "READ_TICKET" - [ testCase "Simple case" $ - readTicket # dip drop -$ Ticket - { tTicketer = addr1 - , tData = [mt|b|] - , tAmount = 5 - } - @?= ReadTicket - { rtTicketer = addr1 - , rtData = [mt|b|] - , rtAmount = 5 - } - ] - - , testGroup "SPLIT_TICKET" - [ testCase "Working case" $ - splitTicket -$ (Ticket addr1 [mt|a|] 5, (2, 3)) - @?= Just (Ticket addr1 [mt|a|] 2, Ticket addr1 [mt|a|] 3) - - , testCase "Invalid sum" $ - splitTicket -$ (Ticket addr1 [mt|a|] 5, (2, 2)) - @?= Nothing - ] - - , testGroup "JOIN_TICKETS" - [ testCase "Working case" $ - joinTickets -$ - ( Ticket addr1 [mt|a|] 5 - , Ticket addr1 [mt|a|] 3 - ) - @?= Just (Ticket addr1 [mt|a|] 8) - - , testCase "Mismatching value" $ - joinTickets -$ - ( Ticket addr1 [mt|a|] 5 - , Ticket addr1 [mt|b|] 3 - ) - @?= Nothing - - , testCase "Mismatching address" $ - joinTickets -$ - ( Ticket addr1 [mt|a|] 5 - , Ticket addr2 [mt|a|] 3 - ) - @?= Nothing - - ] - - ] diff --git a/lorentz-test/Test/Lorentz/Tickets/Contracts.hs b/lorentz-test/Test/Lorentz/Tickets/Contracts.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Tickets/Contracts.hs +++ /dev/null @@ -1,163 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE NoApplicativeDo #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Contracts for tickets tests. -module Test.Lorentz.Tickets.Contracts - ( atomicMissileLaunchContract - - , PermitTokensStorage (..) - , PermitTokensParameter - , permitTokensContract - - , allowancesContract - ) where - -import Prelude (Typeable) - -import Lorentz -import Lorentz.Tickets - --- Errors ----------------------------------------------------------------------------- - -type instance ErrorArg "insufficient_tokens_permitted_by_ticket" = - ("permitted" :! Natural, "spent" :! Natural) - -instance CustomErrorHasDoc "insufficient_tokens_permitted_by_ticket" where - customErrClass = ErrClassActionException - customErrDocMdCause = - "Attempt to spend more tokens than permitted." - ----------------------------------------------------------------------------- --- Contract with authorized action ----------------------------------------------------------------------------- - -atomicMissileLaunchContract - :: (Typeable ticketer) - => TAddress ticketer () -> Contract (Ticket Integer) Bool () -atomicMissileLaunchContract ticketer = defaultContract $ do - car; push ticketer - authorizeAction validateCode - push True; nil; pair - where - validateCode = - push 12345 # eq # if_ nop (failUsing [mt|Bad code|]) - ----------------------------------------------------------------------------- --- Contract with authorized tokens spend from single address ----------------------------------------------------------------------------- - -data PermitTokensStorage = PermitTokensStorage - { ptsPermittedTokens :: Maybe (STicket "tokens" ()) - , ptsAdmin :: Address - -- ^ Who permits tokens spending - } deriving stock (Generic) - deriving anyclass (IsoValue, HasAnnotation) - -instance TypeHasDoc PermitTokensStorage where - typeDocMdDescription = "Storage" - --- TODO: [#585]: avoid uses of next two functions, work with storage --- as with normal ADT -decomposePermitTokensStorage - :: PermitTokensStorage : s - :-> Maybe (STicket "tokens" ()) : Address : s -decomposePermitTokensStorage = forcedCoerce_ # unpair - -composePermitTokensStorage - :: Maybe (STicket "tokens" ()) : Address : s - :-> PermitTokensStorage : s -composePermitTokensStorage = pair # forcedCoerce_ - -instance HasFieldOfType PermitTokensStorage name ty => - StoreHasField PermitTokensStorage name ty where - storeFieldOps = storeFieldOpsADT - -data PermitTokensParameter - = PermitSpend Natural - | PermitAllow (Ticket ()) - | PermitGet (Void_ () Natural) - | PermitSetAdmin Address - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints PermitTokensParameter where - type ParameterEntrypointsDerivation PermitTokensParameter = EpdPlain - --- | A contract that emulates simple allowance functionality, where --- permission is provided via tickets. -permitTokensContract - :: Contract PermitTokensParameter PermitTokensStorage () -permitTokensContract = defaultContract $ do - doc $ dStorage @PermitTokensStorage - unpair; caseT - ( #cPermitSpend /-> do - dip decomposePermitTokensStorage - subtractSTicket (failCustom #insufficient_tokens_permitted_by_ticket) - composePermitTokensStorage - , #cPermitAllow /-> do - dip decomposePermitTokensStorage - dupN @3; checkedCoerce_ @Address - dip toSTicket; verifyTicketer; drop @() - addSTicket - composePermitTokensStorage - , #cPermitGet /-> void_ do - drop @() - stToField #ptsPermittedTokens - sTicketAmount - , #cPermitSetAdmin /-> do - dip $ drop @PermitTokensStorage - none - composePermitTokensStorage - ) - nil; pair - ----------------------------------------------------------------------------- --- Contract with authorized tokens spend from many addresses ----------------------------------------------------------------------------- - -type AllowancesStorage = - BigMap Address (STicket "allowances" ()) - -data AllowancesParameter - = AllowancesSpend (Address, Natural) - | AllowancesAllow (Ticket ()) - | AllowancesGet (Void_ Address Natural) - deriving stock (Generic) - deriving anyclass (IsoValue) - -instance ParameterHasEntrypoints AllowancesParameter where - type ParameterEntrypointsDerivation AllowancesParameter = EpdPlain - --- | A contract that emulates simple allowance functionality, where --- permission is provided via tickets. -allowancesContract - :: Contract AllowancesParameter AllowancesStorage () -allowancesContract = defaultContract $ do - unpair; caseT - ( #cAllowancesSpend /-> do - unpair @Address @Natural; swap - dupN @2 @Address - dip @Address $ do - dip @Natural $ do - dip none; getAndUpdate - subtractSTicket (failCustom #insufficient_tokens_permitted_by_ticket) - update - , #cAllowancesAllow /-> do - toSTicket; dip (drop @()) - dip swap - stackType @[Address, AllowancesStorage, STicket _ _] - dup; dip @Address $ do - dip none; getAndUpdate - dig @2 - addSTicket - update - , #cAllowancesGet /-> void_ do - get; sTicketAmount - ) - nil; pair diff --git a/lorentz-test/Test/Lorentz/Tickets/Helpers.hs b/lorentz-test/Test/Lorentz/Tickets/Helpers.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Tickets/Helpers.hs +++ /dev/null @@ -1,169 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on tickets helpers from "Lorentz.Tickets" module. -module Test.Lorentz.Tickets.Helpers - ( test_ActionAuth - , test_TokenAllowance - ) where - -import Test.Tasty (TestTree, testGroup) - -import Lorentz qualified as L -import Lorentz.Value -import Morley.Util.Named -import Test.Cleveland -import Test.Cleveland.Lorentz.Ticketer - -import Test.Lorentz.Tickets.Contracts - -test_ActionAuth :: [TestTree] -test_ActionAuth = - let prepare - :: MonadCleveland caps m - => m ( ContractHandle (Ticket Integer) Bool () - , ContractHandle (L.View_ ((), (Natural, Integer)) (Ticket Integer)) () () - ) - prepare = do - ticketer <- originateSimple "ticketer" () (ticketerContract' L.drop) - launcher <- originateSimple "launcher" False (atomicMissileLaunchContract $ toTAddress ticketer) - return (launcher, ticketer) - in - [ testScenario "Normal scenario works" $ scenario do - (launcher, ticketer) <- prepare - - callViaTicketer ticketer 1 12345 launcher () - - , testScenario "Bad ticket data causes failure" $ scenario do - (launcher, ticketer) <- prepare - - callViaTicketer ticketer 1 123 launcher () - & expectFailedWith [mt|Bad code|] - - , testScenario "Bad tokens number causes failure" $ scenario do - (launcher, ticketer) <- prepare - - callViaTicketer ticketer 0 12345 launcher () - & expectCustomErrorNoArg #nOT_SINGLE_TICKET_TOKEN - - callViaTicketer ticketer 3 12345 launcher () - & expectCustomErrorNoArg #nOT_SINGLE_TICKET_TOKEN - - , testScenario "Wrong ticketer causes failure" $ scenario do - (launcher, _ticketer) <- prepare - fakeTicketer <- originateSimple "fake-ticketer" () (ticketerContract' L.drop) - - callViaTicketer fakeTicketer 3 12345 launcher () - & expectCustomErrorNoArg #wRONG_TICKETER - - ] - -test_TokenAllowance :: [TestTree] -test_TokenAllowance = - let prepare - :: MonadCleveland caps m - => m ( ContractHandle PermitTokensParameter PermitTokensStorage () - , ContractHandle (L.View_ ((), (Natural, ())) (Ticket ())) () () - ) - prepare = do - ticketer <- originateSimple "ticketer" () (ticketerContract' L.drop) - let initStorage = PermitTokensStorage Nothing (toAddress ticketer) - token <- originateSimple "token" initStorage permitTokensContract - return (token, ticketer) - in - [ testGroup "Allowances" - - [ testScenario "Permitting tokens works" $ scenario do - -- TODO: Would be actually nice to try hedgehog here once it is available for cleveland - - (token, ticketer) <- prepare - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - callViaTicketer ticketer 3 () (callingAddress token (Call @"PermitAllow")) () - - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 8) - - , testScenario "Permitting 0 tokens works" $ scenario do - (token, ticketer) <- prepare - - callViaTicketer ticketer 0 () (callingAddress token (Call @"PermitAllow")) () - - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 0) - - , testScenario "Permitting tokens from wrong ticketer fails" $ scenario do - (token, _ticketer) <- prepare - fakeTicketer <- originateSimple "fake-ticketer" () (ticketerContract' L.drop) - - callViaTicketer fakeTicketer 1 () (callingAddress token (Call @"PermitAllow")) () - & expectCustomErrorNoArg #wRONG_TICKETER - - ] - - , testGroup "Spendings" - - [ testScenario "Spending tokens works" $ scenario do - (token, ticketer) <- prepare - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSpend") 3 - - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 2) - - , testScenario "Spending too many tokens fails" $ scenario do - (token, ticketer) <- prepare - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSpend") 8 - & expectCustomError #insufficient_tokens_permitted_by_ticket - (#permitted :! 5, #spent :! 8) - - , testScenario "Can repeatedly exhaust all allowances" $ scenario do - (token, ticketer) <- prepare - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSpend") 3 - call token (Call @"PermitSpend") 2 - callViaTicketer ticketer 0 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSpend") 0 - callViaTicketer ticketer 1 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSpend") 1 - callViaTicketer ticketer 3 () (callingAddress token (Call @"PermitAllow")) () - - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 3) - - ] - - , testGroup "Admin change" - - [ testScenario "Admin change takes effect" $ scenario do - (token, ticketer) <- prepare - ticketer2 <- originateSimple "ticketer2" () (ticketerContract' L.drop) - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitSetAdmin") (toAddress ticketer2) - - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 0) - - callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) () - & expectCustomErrorNoArg #wRONG_TICKETER - - callViaTicketer ticketer2 5 () (callingAddress token (Call @"PermitAllow")) () - call token (Call @"PermitGet") (L.mkVoid ()) - & expectError (L.VoidResult @Natural 5) - - ] - ] - -{- We do not cover 'allowancesContract' with tests since there is nothing -special there comparing to 'permitTokensContract', the contract exists only to -demonstrate implementation for a contract that stores an entire map of tickets. --} -_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 deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Timelock.hs +++ /dev/null @@ -1,80 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on basic timelock puzzle, i.e. 'openChest' functionality -module Test.Lorentz.Timelock - ( test_Interpreter - ) where - -import Lorentz -import Prelude (Num, fst, id, snd, (/=), (<$>)) - -import Hedgehog (forAll, property, withTests, (===)) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import Test.Tasty (TestName, TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Tezos.Crypto.Timelock -import Morley.Tezos.Crypto.Timelock hiding (openChest) - -natTime :: Num a => a -natTime = 1000 - -time :: TLTime -time = UnsafeTLTime natTime - -bogusOpening, bogusCipher :: ByteString -bogusOpening = "\1BogusOpening" -bogusCipher = "\0BogusCipher" - --- | This is a Lorentz equivalent of @open_chest.tz@ -openChestTLambda :: Lambda (ChestKey, ChestT ByteString) ByteString -openChestTLambda = - unpair - # dipN @2 (push @Natural natTime) - # openChestT - # caseT - ( #cChestContentT /-> nop - , #cChestOpenFailedT /-> if_ (push bogusOpening) (push bogusCipher) - ) - --- | This is a Lorentz equivalent of @open_chest.tz@ -openChestLambda :: Lambda (ChestKey, Chest) ByteString -openChestLambda = - unpair - # dipN @2 (push @Natural natTime) - # openChest - # caseT - ( #cChestContent /-> nop - , #cChestOpenFailed /-> if_ (push bogusOpening) (push bogusCipher) - ) - -test_Interpreter :: [TestTree] -test_Interpreter = - [ treeImpl "Chest" openChestLambda id - , treeImpl "ChestT" openChestTLambda ChestT - ] - -treeImpl :: IsoValue a => TestName -> (Lambda (ChestKey, a) ByteString) -> (Chest -> a) -> TestTree -treeImpl nm tstf conv = testGroup nm - [ testProperty "Chest value decodes" $ property do - ((chest, key), (payload, _)) <- forAll $ genChestAndKeyWithParams (Just time) - (tstf -$ (key, conv chest)) === payload - , testProperty "Chest value doesn't decode with a wrong key" $ withTests 50 $ property do - (chest, key) <- fst <$> forAll (Gen.small $ genChestAndKeyWithParams (Just time)) - (chest', key') <- fst <$> - forAll (Gen.filter ((/= key) . snd . fst) $ Gen.small $ genChestAndKeyWithParams (Just time)) - (tstf -$ (key', conv chest)) === bogusOpening - (tstf -$ (key, conv chest')) === bogusOpening - , testProperty "Chest value doesn't decode with a bogus ciphertext" $ property do - (Chest{..}, key) <- fst <$> forAll (genChestAndKeyWithParams (Just time)) - let Ciphertext{..} = chestCiphertext - payload' <- forAll . Gen.filter (/= ctPayload) $ Gen.bytes (Range.constant 100 500) - (tstf -$ (key, conv Chest{chestCiphertext=Ciphertext{ctPayload = payload', ..}, ..})) - === bogusCipher - , testProperty "Chest value doesn't decode with a wrong time" $ property do - (chest, key) <- fst <$> - forAll (Gen.filter ((/= time) . snd . snd) $ genChestAndKeyWithParams Nothing) - (tstf -$ (key, conv chest)) === bogusOpening - ] diff --git a/lorentz-test/Test/Lorentz/UParam.hs b/lorentz-test/Test/Lorentz/UParam.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/UParam.hs +++ /dev/null @@ -1,95 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz 'UParam'. -module Test.Lorentz.UParam - ( test_Simple_contract - , test_ADT_conversion - , unit_unpackUParam - ) 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 Lorentz qualified as L -import Lorentz.Base -import Lorentz.Run.Simple -import Lorentz.UParam -import Morley.Michelson.Interpret.Pack -import Morley.Michelson.Text -import Test.Cleveland.Instances () - --- Test on simple contract ----------------------------------------------------------------------------- - -type Entries = ["add" ?: Natural, "id" ?: ()] - -simpleCode :: '[UParam Entries, Integer] :-> '[Integer] -simpleCode = caseUParamT - ( #add /-> L.add - , #id /-> L.drop @() - ) uparamFallbackFail - -test_Simple_contract :: [TestTree] -test_Simple_contract = - [ testCase "Passing parameter 1" $ - runSimpleCode 5 (mkUParam #add 3) @?= Right 8 - , testCase "Passing parameter 2" $ - runSimpleCode 5 (mkUParam #id ()) @?= Right 5 - , testCase "Passing illegal parameter" $ - assertBool "Expected failure" $ - isLeft $ - runSimpleCode 5 (UnsafeUParam ("Nyan", "")) - ] - where - runSimpleCode initVal uparam = simpleCode -$? (uparam, initVal) - --- Test deconstruction ----------------------------------------------------------------------------- - -unit_unpackUParam :: Assertion -unit_unpackUParam = do - unpk (mkUParam #add 3) @?= - Right ("add", "3") - unpk (mkUParam #id ()) @?= - Right ("id", "()") - unpk (UnsafeUParam ("gy", mempty)) @?= - Left (NoSuchEntrypoint "gy") - unpk (UnsafeUParam ("add", mempty)) @?= - Left ArgumentUnpackFailed - where - unpk :: - UParam Entries -> - Either EntrypointLookupError (MText, String) - unpk = fmap (second pretty) . unpackUParam @Buildable - --- Test ADT conversion ----------------------------------------------------------------------------- - -data Parameter1 - = MyEntrypoint1 Integer - | MyEntrypoint2 () - deriving stock (Generic) - -type ExpectedLinearization1 = - [ "MyEntrypoint1" ?: Integer - , "MyEntrypoint2" ?: () - ] - -_checkLinearizedType - :: Dict (UParamLinearized Parameter1 ~ ExpectedLinearization1) -_checkLinearizedType = Dict - -test_ADT_conversion :: [TestTree] -test_ADT_conversion = - [ testCase "Linearization 1.1" $ - uparamFromAdt (MyEntrypoint1 5) - @?= UnsafeUParam ("MyEntrypoint1", packValue' (L.toVal @Integer 5)) - , testCase "Linearization 1.2" $ - uparamFromAdt (MyEntrypoint2 ()) - @?= UnsafeUParam ("MyEntrypoint2", packValue' (L.toVal ())) - ] diff --git a/lorentz-test/Test/Lorentz/Views.hs b/lorentz-test/Test/Lorentz/Views.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/Views.hs +++ /dev/null @@ -1,187 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz on-chain views. - -module Test.Lorentz.Views - ( test_Views - ) where - -import Lorentz -import Prelude hiding (drop, some, swap, take, view) - -import Data.Coerce (coerce) -import Test.Tasty (TestTree, testGroup) - -import Morley.Util.Type -import Test.Cleveland -import Test.Cleveland.Lorentz.Requester - -data Views1 -type instance RevealViews Views1 = - [ "plusSt" ?:: Natural >-> Natural - , "fail" ?:: MText >-> Never - , "stPow" ?:: Natural >-> Natural - ] ++ - RevealViews PlusView - -data PlusView deriving stock (Generic) -type instance RevealViews PlusView = - '[ "plus" ?:: (Integer, Integer) >-> Integer - ] -instance ViewsDescriptorHasDoc PlusView - -viewedContract1 :: Contract Never Natural Views1 -viewedContract1 = compileLorentzContract $ - defaultContractData - (car # never) - & setViews - ( mkView @"plusSt" (unpair # add) - , mkView @"fail" (car # failWith) - , mkView @"stPow" - ( car # - push @Integer 1 # rsub # isNat # ifSome - ( -- call the same view recursively - viewE @"plusSt" - ! #address do selfAddress # asAddressOf_ viewedContract1 - ! #arg do push 0 - |*| - -- call another view - viewE @"stPow" - ! #address do selfAddress # asAddressOf_ viewedContract1 - ! #arg take - ) - ( push 1 ) - ) - , mkView @"plus" (car # unpair # add) - ) - -data Views2 -type instance RevealViews Views2 = - '[ "plus10" - -- TODO [#716]: here we should use not TAddress but something else that - -- 1. does not carry the parameter type - -- 2. can narrow the list of views when converted from e.g. ContractHandle - -- (because we are fine with any contract that contains more views, not only - -- 'PlusView') - -- - -- For now, we have to cast 'TAddress'. - ?:: (Integer, TAddress () PlusView) - >-> Integer - ] - -viewedContract2 :: Contract Never () Views2 -viewedContract2 = compileLorentzContract $ - defaultContractData - (car # never) - & setViews - ( mkView @"plus10" (car # unpair # push 10 # pair # view @"plus") - ) - -data AccessAddrView -type instance RevealViews AccessAddrView = - '[ "originatedContract" ?:: () >-> TAddress Never PlusView - ] - --- | On call originates a contract with 'PlusView' view and save its address in storage. --- The view in the originated contract will sum up two numbers and add extra 100. -view3OriginatorContract :: Contract () (Maybe (TAddress Never PlusView)) AccessAddrView -view3OriginatorContract = compileLorentzContract $ - defaultContractData - ( drop # - pairE - ( createContractE - ! #storage (push 100) - ! #delegate none - ! #balance (push zeroMutez) - ! #contract newContract - |:| nil - , some - ) - ) - & setViews - ( mkView @"originatedContract" (cdr # assertSome [mt|Nothing originated|]) - ) - where - newContract = compileLorentzContract @Never @Natural @PlusView $ - defaultContractData (car # never) - & setViews - ( mkView @"plus" (unpair # unpair # add # add) - ) - --- | On call, calls the view in the contract originated by 'view3OriginatorContract'. -view3Caller :: Contract () (TAddress () AccessAddrView, Maybe Integer) () -view3Caller = mkContract $ - cdr # - car # - stackType @'[TAddress () AccessAddrView] # - viewE @"plus" - ! #arg do push (10, 1) - ! #address do - viewE @"originatedContract" - ! #arg unit - ! #address dup - # - stackType @[Integer, TAddress () AccessAddrView] # - swap # - pairE (take, some) # - nil # pair - --- | Calls 'view3OriginatorContract' and 'view3Caller' sequentially. -view3CreatorAndCaller :: Contract (ContractRef (), ContractRef ()) () () -view3CreatorAndCaller = mkContract $ - car # - unpair # - transferTokensE - ! #arg unit - ! #amount (push zeroMutez) - ! #contract take - |:| - transferTokensE - ! #arg unit - ! #amount (push zeroMutez) - ! #contract take - |:| nil - |@| unit - -test_Views :: TestTree -test_Views = testGroup "Views" - [ testScenario "Simple case with requester contract" $ scenario do - viewed <- originateSimple "viewed" 1 viewedContract1 - requester <- originateSimple "requester" [] (contractRequester @"plusSt" viewed) - forM_ [5, 10] $ call requester CallDefault - getStorage requester @@== [11, 6] - - -- TODO [#708]: Call views directly, without requester contract - - , testScenario "Failing view" $ scenario do - viewed <- originateSimple "viewed" 0 viewedContract1 - requester <- originateSimple "requester" [] (contractRequester @"fail" viewed) - call requester CallDefault [mt|nyan|] - & expectFailedWith [mt|nyan|] - - , testScenario "Recursive view" $ scenario do - viewed <- originateSimple "viewed" 2 viewedContract1 - requester <- originateSimple "requester" [] (contractRequester @"stPow" viewed) - forM_ [5, 0] $ call requester CallDefault - getStorage requester @@== [1, 32] - - , testScenario "Calling view in another contract" $ scenario do - viewedHelper <- originateSimple "viewed" 0 viewedContract1 - viewed <- originateSimple "viewed" () viewedContract2 - requester <- originateSimple "requester" [] (contractRequester @"plus10" viewed) - -- TODO [#716]: coerce shouldn't be necessary - call requester CallDefault (20, coerce $ toTAddress viewedHelper) - getStorage requester @@== [30] - - , testScenario "Calling a just originated view" $ scenario do - -- It might be that a view is originated and called within the same - -- global operation, we want to be sure this works - originator <- originateSimple "originator" Nothing view3OriginatorContract - caller <- originateSimple "caller" (toTAddress originator, Nothing) view3Caller - allCaller <- originateSimple "allCaller" () view3CreatorAndCaller - - call allCaller CallDefault (toContractRef originator, toContractRef caller) - snd <$> getStorage caller @@== Just 111 - - ] diff --git a/lorentz-test/Test/Lorentz/ViewsImport.hs b/lorentz-test/Test/Lorentz/ViewsImport.hs deleted file mode 100644 --- a/lorentz-test/Test/Lorentz/ViewsImport.hs +++ /dev/null @@ -1,97 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on importing Lorentz contracts with views. - -module Test.Lorentz.ViewsImport - ( test_ViewsImport - ) where - -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 Morley.Michelson.Typed qualified as T -import Test.Cleveland.Lorentz.Import - -data AllViews -type instance RevealViews AllViews = - '[ "add" ?:: Natural >-> Natural - , "id" ?:: Natural >-> (Natural, ()) - , "fail" ?:: MText >-> Never - ] - -data IdView -type instance RevealViews IdView = - '[ "id" ?:: Natural >-> (Natural, ()) - ] - -data WrongIdView1 -type instance RevealViews WrongIdView1 = - '[ "id" ?:: Integer >-> (Natural, ()) - ] - -data WrongIdView2 -type instance RevealViews WrongIdView2 = - '[ "id" ?:: Natural >-> (Integer, ()) - ] - -data NonExistentView -type instance RevealViews NonExistentView = - '[ "idd" ?:: Natural >-> (Natural, ()) - ] - -data FewViews -type instance RevealViews FewViews = - '[ "fail" ?:: MText >-> Never - , "add" ?:: Natural >-> Natural - ] - -data WrongViewsSet -type instance RevealViews WrongViewsSet = - '[ "fail" ?:: MText >-> () - , "add" ?:: Natural >-> Natural - ] - -test_ViewsImport :: TestTree -test_ViewsImport = testGroup "Views imports" - let contractPath = inContractsDir "view_example.tz" - importContract' - :: forall vd. (NiceViewsDescriptor vd, DemoteViewsDescriptor vd) - => IO () - importContract' = evaluateNF_ =<< importContract @() @() @vd contractPath - in - [ testCase "All views" do - importContract' @AllViews - - , testCase "One present view" do - importContract' @IdView - - , testCase "One view with wrong arg type" do - importContract' @WrongIdView1 - `catch` \e -> - e @?= VIMViewArgMismatch MkMismatchError{meActual=T.TNat, meExpected=T.TInt} - - , testCase "One view with wrong ret type" do - importContract' @WrongIdView2 - `catch` \e -> - e @?= VIMViewRetMismatch MkMismatchError - {meActual=T.TPair T.TNat T.TUnit, meExpected=T.TPair T.TInt T.TUnit} - - , testCase "Non-existent view" do - importContract' @NonExistentView - `catch` \e -> - e @?= VIMViewNotFound (UnsafeViewName "idd") - - , testCase "Few present views" do - importContract' @FewViews - - , testCase "All views and one wrong view" do - importContract' @WrongViewsSet - `catch` \e -> - 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 deleted file mode 100644 --- a/lorentz-test/Test/Tasty/TypeSpec.hs +++ /dev/null @@ -1,32 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tasty integration for TypeSpec. -module Test.Tasty.TypeSpec - ( typeTest - ) where - -import Test.Tasty.Providers (IsTest(..), TestName, TestTree, singleTest, testPassed) -import Test.TypeSpec.Core (PrettyTypeSpec, TypeSpec(..)) - -data TypeTestCase = - 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) _ = - -- TypeSpec test suites are ensured at compile time. - return . testPassed $ show spec - - testOptions = pure [] - --- | Turn a 'TypeSpec' into tasty test case. -typeTest - :: PrettyTypeSpec expectation - => TestName -> TypeSpec expectation -> TestTree -typeTest name spec = singleTest name (TypeTestCase spec) diff --git a/lorentz-test/Test/Util/Annotation.hs b/lorentz-test/Test/Util/Annotation.hs deleted file mode 100644 --- a/lorentz-test/Test/Util/Annotation.hs +++ /dev/null @@ -1,84 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Util.Annotation - ( FieldAnnTree (..) - , TypeAnnTree (..) - , extractFieldAnnTree - , extractTypeAnnTree - ) where - -import Morley.Michelson.Typed -import Morley.Michelson.Untyped (FieldAnn, TypeAnn, noAnn) - --- | Helper datatype which contains field annotations from the given type -data FieldAnnTree t where - FALeaf :: FieldAnnTree t - FANodeOr :: FieldAnn -> FieldAnnTree a - -> FieldAnn -> FieldAnnTree b - -> FieldAnnTree ('TOr a b) - FANodePair :: FieldAnn -> FieldAnnTree a - -> FieldAnn -> FieldAnnTree b - -> FieldAnnTree ('TPair a b) - -deriving stock instance Eq (FieldAnnTree t) -deriving stock instance Show (FieldAnnTree t) - -extractFieldAnnTree :: Notes t -> FieldAnnTree t -extractFieldAnnTree = \case - NTOr _ lann rann lnotes rnotes -> - FANodeOr lann (extractFieldAnnTree lnotes) rann (extractFieldAnnTree rnotes) - NTPair _ lann rann _ _ lnotes rnotes - | lann == noAnn && rann == noAnn -> FALeaf - | otherwise -> FANodePair lann (extractFieldAnnTree lnotes) rann (extractFieldAnnTree rnotes) - _ -> - FALeaf - --- | Helper datatype which contains type annotations from the given type -data TypeAnnTree t where - TALeaf :: TypeAnn -> TypeAnnTree t - TANodeOption :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TOption a) - TANodePair :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TPair a b) - TANodeOr :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TOr a b) - TANodeLambda :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TLambda a b) - TANodeList :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TList a) - TANodeMap :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TMap a b) - TANodeBigMap :: TypeAnn ->TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TBigMap a b) - -deriving stock instance Eq (TypeAnnTree t) -deriving stock instance Show (TypeAnnTree t) - -extractTypeAnnTree :: Notes t -> TypeAnnTree t -extractTypeAnnTree = \case - NTKey ta -> TALeaf ta - NTUnit ta -> TALeaf ta - NTSignature ta -> TALeaf ta - NTOption ta n1 -> TANodeOption ta (extractTypeAnnTree n1) - NTList ta n1 -> TANodeList ta (extractTypeAnnTree n1) - NTSet ta _ -> TALeaf ta - NTOperation ta -> TALeaf ta - NTContract ta _ -> TALeaf ta - NTTicket ta _ -> TALeaf ta - NTPair ta _ _ _ _ n1 n2 -> TANodePair ta (extractTypeAnnTree n1) (extractTypeAnnTree n2) - NTOr ta _ _ n1 n2 -> TANodeOr ta (extractTypeAnnTree n1) (extractTypeAnnTree n2) - NTLambda ta n1 n2 -> TANodeLambda ta (extractTypeAnnTree n1) (extractTypeAnnTree n2) - NTMap ta n1 n2 -> TANodeMap ta (extractTypeAnnTree n1) (extractTypeAnnTree n2) - NTBigMap ta n1 n2 -> TANodeBigMap ta (extractTypeAnnTree n1) (extractTypeAnnTree n2) - NTChainId ta -> TALeaf ta - NTInt ta -> TALeaf ta - NTNat ta -> TALeaf ta - NTString ta -> TALeaf ta - NTBytes ta -> TALeaf ta - NTMutez ta -> TALeaf ta - NTBool ta -> TALeaf ta - NTKeyHash ta -> TALeaf ta - NTBls12381Fr ta -> TALeaf ta - NTBls12381G1 ta -> TALeaf ta - NTBls12381G2 ta -> TALeaf ta - NTTimestamp ta -> TALeaf ta - NTAddress ta -> TALeaf ta - 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 deleted file mode 100644 --- a/lorentz-test/Test/Util/TypeSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Util.TypeSpec - ( ExactlyIs - ) where - -import Data.Singletons.Prelude.Eq (DefaultEq) -import Morley.Util.Type (If) -import Morley.Util.TypeLits (ErrorMessage(..)) -import Test.TypeSpec.Core (EvalExpectation, FAILED, OK, PrettyTypeSpec(..)) - --- | Like 'Is' but ensures that arguments match in kind. -data ExactlyIs (actual :: k) (expected :: k) -type instance EvalExpectation (ExactlyIs actual expected) = - If (DefaultEq actual expected) - (OK (ExactlyIs actual expected)) - (FAILED - ('Text "Expected type: " ':<>: 'ShowType expected - ':$$: 'Text "Actual type: " ':<>: 'ShowType actual)) - -instance PrettyTypeSpec (ExactlyIs a b) where - prettyTypeSpec _px = "Equal" diff --git a/lorentz-test/Tree.hs b/lorentz-test/Tree.hs deleted file mode 100644 --- a/lorentz-test/Tree.hs +++ /dev/null @@ -1,5 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/morley-bench/Main.hs b/morley-bench/Main.hs deleted file mode 100644 --- a/morley-bench/Main.hs +++ /dev/null @@ -1,74 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Main (main) where - -import Data.Default (def) -import Data.Text.IO.Utf8 qualified as Utf8 (readFile) -import Gauge.Main (bench, bgroup, defaultMain, nf) -import Main.Utf8 (withUtf8) -import Text.Megaparsec (parse) - -import Morley.Michelson.Interpret (interpret) -import Morley.Michelson.Parser as P -import Morley.Michelson.Runtime (prepareContract) -import Morley.Michelson.Runtime.Dummy -import Morley.Michelson.Text -import Morley.Michelson.TypeCheck as T -import Morley.Michelson.Typed as T -import Morley.Tezos.Address -import Test.Cleveland.Michelson.Import (importContract) - -main :: IO () -main = withUtf8 $ do - let - basicFp = "../../contracts/basic1.tz" - stringCallerFp = "../../contracts/string_caller.tz" - callSelfFp = "../../contracts/call_self_several_times.tz" - sq2Fp = "../../contracts/testassert_square2.mtz" - contractPaths = [basicFp, stringCallerFp, callSelfFp, sq2Fp] - contracts <- traverse (\x -> (x,) <$> Utf8.readFile x) contractPaths - let makeParseBench (filename, code) = - bench filename $ nf (parse P.program filename) code - preparedContracts <- evaluateNF =<< traverse (\x -> (x,) <$> prepareContract (Just x)) contractPaths - let - makeTypeCheckBench (filename, contract) = bench filename $ - nf (T.typeCheckingWith def . T.typeCheckContract) contract - - basicC <- importContract basicFp - stringCallerC <- importContract stringCallerFp - callSelfC <- importContract callSelfFp - sq2C <- importContract sq2Fp - let - basicBench = bench basicFp - (nf - (interpret basicC T.epcPrimitive T.VUnit (T.VList [T.VInt 0]) dummyGlobalCounter dummyBigMapCounter) - dummyContractEnv - ) - - dummyAddress = detGenKeyAddress "thegreatandpowerful" - dummyString = unsafe . mkMText $ "TGAP" - stringCallerBench = bench stringCallerFp - (nf - (interpret stringCallerC T.epcPrimitive (T.toVal dummyString) (T.toVal dummyAddress) dummyGlobalCounter dummyBigMapCounter) - dummyContractEnv - ) - callSelfBench = bench callSelfFp - (nf - (interpret callSelfC T.epcPrimitive (T.toVal (100 :: Integer)) (T.toVal (0 :: Natural)) dummyGlobalCounter dummyBigMapCounter) - dummyContractEnv - ) - - sq2Bench = bench sq2Fp - (nf - (interpret sq2C T.epcPrimitive (T.toVal (100 :: Integer, 200 :: Integer)) T.VUnit dummyGlobalCounter dummyBigMapCounter) - dummyContractEnv - ) - - - - defaultMain - [ bgroup "parsing" $ map makeParseBench contracts - , bgroup "type-checking" $ map makeTypeCheckBench preparedContracts - , bgroup "interpreting" $ [basicBench, stringCallerBench, callSelfBench, sq2Bench] - ] diff --git a/morley-client-test/Main.hs b/morley-client-test/Main.hs deleted file mode 100644 --- a/morley-client-test/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Main - ( main - ) where - -import Test.Cleveland.Ingredients (ourIngredients) -import Test.Cleveland.Tasty (clevelandMainWithIngredients) - -import Tree (tests) - -main :: IO () -main = tests >>= clevelandMainWithIngredients ourIngredients diff --git a/morley-client-test/Test/Fee.hs b/morley-client-test/Test/Fee.hs deleted file mode 100644 --- a/morley-client-test/Test/Fee.hs +++ /dev/null @@ -1,132 +0,0 @@ --- 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 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(..), 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, calcRevealFee, calcTransferFee, importKey) -import Morley.Client.TezosClient.Types - (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.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) -import Test.Cleveland.Tasty (whenNetworkEnabled) - -import Test.Util.Contracts (contractsDir, ()) - -test_FeeCalculation :: IO TestTree -test_FeeCalculation = pure $ whenNetworkEnabled $ \withEnv -> - testGroup "Compare morley-client fee calulation with tezos-client" - [ testCase "single transfer in a batch has the same fee" $ do - compareTransferFeeCalculation withEnv $ one $ trivialTransfer - , testCase "multiple transfers in a batch have the same fee" $ do - compareTransferFeeCalculation withEnv $ NE.fromList $ replicate 5 trivialTransfer - , testCase "origination has the same fee" $ do - soBigContract <- importContract @(ToT ()) @(ToT ()) $ contractsDir "so_big.tz" - compareOriginationFeeCalculation withEnv $ OriginationData - { odReplaceExisting = True - , odName = "so_big" - , odBalance = zeroMutez - , odContract = soBigContract - , odStorage = toVal () - , odMbFee = Nothing - } - , testCase "reveal has the same fee" $ do - compareRevealFeeCalculation withEnv - ] - where - trivialTransfer = TransactionData $ TD - { tdReceiver = genesisAddress - , tdAmount = 100 - , tdEpName = DefEpName - , tdParam = toVal () - , tdMbFee = Nothing - } - -compareTransferFeeCalculation - :: ((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 OpTransfer transferBatch) - pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters - feesTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcTransferFee - (AddressResolved moneybagAddr) Nothing (computeStorageLimit appliedResults pp) - (map transactionDataToCalcTransferFeeData $ toList transferBatch) - feesMorleyClient @?= feesTezosClient - where - transactionDataToCalcTransferFeeData :: TransactionData -> CalcTransferFeeData - transactionDataToCalcTransferFeeData (TransactionData TD{..}) = CalcTransferFeeData - { ctfdTo = AddressResolved $ tdReceiver - , ctfdParam = tdParam - , ctfdEp = tdEpName - , ctfdAmount = TezosMutez tdAmount - } - -compareOriginationFeeCalculation - :: ((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 $ OpOriginate od) - pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters - feeTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcOriginationFee - CalcOriginationFeeData - { cofdFrom = AddressResolved moneybagAddr - , cofdBalance = TezosMutez odBalance - , cofdMbFromPassword = Nothing - , cofdContract = odContract - , cofdStorage = odStorage - , 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 deleted file mode 100644 --- a/morley-client-test/Test/RPCKeyRevealing.hs +++ /dev/null @@ -1,67 +0,0 @@ --- 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-client-test/Tree.hs b/morley-client-test/Tree.hs deleted file mode 100644 --- a/morley-client-test/Tree.hs +++ /dev/null @@ -1,5 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/morley-test/Main.hs b/morley-test/Main.hs deleted file mode 100644 --- a/morley-test/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Main - ( main - ) where - -import Test.Cleveland.Ingredients (ourIngredients) -import Test.Cleveland.Tasty (clevelandMainWithIngredients) - -import Tree (tests) - -main :: IO () -main = tests >>= clevelandMainWithIngredients ourIngredients diff --git a/morley-test/Test/Analyzer.hs b/morley-test/Test/Analyzer.hs deleted file mode 100644 --- a/morley-test/Test/Analyzer.hs +++ /dev/null @@ -1,56 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for analyzer. - -module Test.Analyzer - ( unit_Sample_analyze - ) where - -import Prelude hiding (EQ) - -import Data.HashMap.Strict qualified as HM -import Test.HUnit (Assertion, (@?=)) - -import Morley.Michelson.Analyzer -import Morley.Michelson.Text -import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Typed.Instr -import Test.Cleveland.Instances () - -unit_Sample_analyze :: Assertion -unit_Sample_analyze = analyze sample @?= expectedRes - where - expectedRes = AnalyzerRes - { arConstStrings = HM.fromList [(str1, 3), (str3, 4)] - , arConstBytes = mempty - , arErrorTags = HM.fromList [(str1, 2), (str3, 1)] - } - -str1 :: MText -str1 = "aa" - -str3 :: MText -str3 = "bb" - -sample :: T.ContractCode 'T.TString 'T.TString -sample = - CAR `Seq` DUP `Seq` - pushStr str3 `Seq` - CONCAT `Seq` - SIZE `Seq` INT `Seq` EQ `Seq` - IF (LAMBDA (T.VLam . T.RfNormal $ pushStr str3 `Seq` CONCAT) `Seq` DROP) - (DIP (pushStr str1) `Seq` DROP) `Seq` - DIP (pushStr str3) `Seq` DROP `Seq` - pushTrue `Seq` - IF (pushStr str1 `Seq` FAILWITH) - pushTrue `Seq` - IF (Seq NOW $ Seq DROP $ pushStr str1 `Seq` (PAIR `Seq` FAILWITH)) - Nop `Seq` - PUSH (T.VPair (T.VString str3, T.VUnit)) `Seq` FAILWITH - where - pushStr :: forall s. MText -> Instr s ('T.TString ': s) - pushStr str = PUSH (T.VString str) - - pushTrue :: forall s. Instr s ('T.TBool ': s) - pushTrue = PUSH (T.VBool True) diff --git a/morley-test/Test/AsRPC.hs b/morley-test/Test/AsRPC.hs deleted file mode 100644 --- a/morley-test/Test/AsRPC.hs +++ /dev/null @@ -1,647 +0,0 @@ --- 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 deleted file mode 100644 --- a/morley-test/Test/Doc/Position.hs +++ /dev/null @@ -1,40 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Doc.Position - ( test_DifferentPosition - , test_SamePosition - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Doc -import Morley.Michelson.Typed.Haskell (DStorageType, DType) -import Test.Cleveland.Util (goesBefore) - --- | Tests 'docItemPosition'. -test_DifferentPosition :: [TestTree] -test_DifferentPosition = - [ Proxy @DComment `goesBefore` Proxy @DGeneralInfoSection - , Proxy @DGeneralInfoSection `goesBefore` Proxy @DGitRevision - , Proxy @DGitRevision `goesBefore` Proxy @DStorageType - , Proxy @DStorageType `goesBefore` Proxy @DType - ] - -test_SamePosition :: [TestTree] -test_SamePosition = - [ Proxy @DTypeA `goesBefore` Proxy @DTypeB - ] - --- | Custom 'DocItem' for testing purpose. -data DTypeA = DTypeA -instance DocItem DTypeA where - docItemPos = 1 - docItemSectionName = Nothing - docItemToMarkdown _ DTypeA = "" - -data DTypeB = DTypeB -instance DocItem DTypeB where - docItemPos = 1 - docItemSectionName = Nothing - docItemToMarkdown _ DTypeB = "" diff --git a/morley-test/Test/Entrypoints.hs b/morley-test/Test/Entrypoints.hs deleted file mode 100644 --- a/morley-test/Test/Entrypoints.hs +++ /dev/null @@ -1,182 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. -module Test.Entrypoints - ( test_default_EpName - , test_EpAddress - , test_ParseEpAddressRaw - , test_ParamNotes - , test_ParamEpError - , test_contractHasEntrypoints - ) where - -import Prelude hiding (or) - -import Data.Default (def) -import Data.Map qualified as Map -import Fmt (pretty) -import Test.HUnit (assertBool, (@?=)) -import Test.Hspec (shouldSatisfy) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Michelson.Typed (genEpAddress) -import Hedgehog.Gen.Tezos.Address (genAddress) -import Morley.Michelson.Parser (uparamTypeQ, utypeQ) -import Morley.Michelson.TypeCheck (HST(..)) -import Morley.Michelson.TypeCheck qualified as TC -import Morley.Michelson.Typed -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) - -import Test.Util.Hedgehog - -test_default_EpName :: [TestTree] -test_default_EpName = - [ testCase "`CONTRACT %default` is invalid" $ - flip shouldSatisfy isInvalidEpName $ - TC.typeCheckingWith def $ - TC.runTypeCheck TC.TypeCheckTest $ - TC.typeCheckList [U.PrimEx $ U.CONTRACT noAnn ("default" :: U.FieldAnn) U.tyunit] - ((starNotes @'TAddress, Dict, noAnn) ::& SNil) - , testCase "`SELF %default` is valid" $ - flip shouldSatisfy isRight $ - TC.typeCheckingWith def $ - TC.runTypeCheck (TC.TypeCheckContract unitParamType) $ - TC.typeCheckList [U.PrimEx $ U.SELF noAnn ("default" :: U.FieldAnn)] SNil - ] - where - isInvalidEpName :: Either TC.TCError a -> Bool - isInvalidEpName = \case - Left (TC.TCFailedOnInstr _ _ _ _ (Just (TC.IllegalEntrypoint {}))) -> True - _ -> False - - unitParamType :: TC.SomeParamType - unitParamType = - unsafe $ - TC.mkSomeParamType (U.ParameterType U.tyunit noAnn) - -test_EpAddress :: [TestTree] -test_EpAddress = - [ testGroup "Parsing" $ - [ testCase "Simple entrypoint" $ - parseEpAddress (formatAddress addr <> "%ab") - @?= Right (EpAddress addr (unsafe . buildEpName $ "ab")) - - , testCase "No entrypoint" $ - parseEpAddress (formatAddress addr) - @?= Right (EpAddress addr DefEpName) - - , testCase "Weird entrypoint" $ - parseEpAddress (formatAddress addr <> "%a%b") - @?= Right (EpAddress addr (unsafe . buildEpName $ "a%b")) - ] - - , testGroup "parse . format = pure" - [ roundtripTreeSTB genEpAddress formatEpAddress parseEpAddress ] - ] - where - addr = runGen 20 123 genAddress - -test_ParseEpAddressRaw :: [TestTree] -test_ParseEpAddressRaw = mconcat - [ [ testCase ("Successfully encodes " <> toString b) - (formatEpAddress ((unsafe . parseEpAddressRaw) (unsafe $ fromHex b)) @?= a) - | (a, b) <- sampleEpAddresses - ] - , [ testCase ("Fails to parse invalid address " <> toString a) - ((fromHex a >>= first pretty . parseEpAddressRaw) `shouldSatisfy` isLeft) - | a <- invalidRawEpAddresses - ] - ] - -test_ParamNotes :: [TestTree] -test_ParamNotes = - [ testGroup "Duplications are handled" $ - [ testCase "One duplicated entrypoint" $ - mkParamNotes (or "a" "a" prim prim) noAnn - @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| [])) - , testCase "Several duplicated entrypoint" $ - mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn - @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| [unsafe . buildEpName $ "b"])) - , testCase "Duplicated default entrypoint" $ - mkParamNotes (or "default" "default" prim prim) noAnn - @?= Left (ParamEpDuplicatedNames (DefEpName :| [])) - ] - - , testGroup "All entrypoints callable check" $ - [ testCase "Non-callable entrypoint is detected in simple case" $ - mkParamNotes (or "default" "" prim (or "" "q" prim prim)) noAnn - @?= Left (ParamEpUncallableArm [AcRight, AcLeft]) - , testCase "Non-callable entrypoint is detected in complex case" $ - mkParamNotes (or "a" "" prim (or "" "default" (or "b" "" prim prim) prim)) noAnn - @?= Left (ParamEpUncallableArm [AcRight, AcLeft, AcRight]) - - , testCase "Having all leaves named is enough for callability" $ - mkParamNotes (or "default" "" prim (or "q" "" prim (or "a" "b" prim prim))) noAnn - & assertBool "All arms should've considered callable" . isRight - , testCase "Having all leaves named is enough for callability" $ - mkParamNotes (or "default" "a" prim (or "" "" prim (or "" "" prim prim))) noAnn - & assertBool "All arms should've considered callable" . isRight - ] - ] - where - or a1 a2 = NTOr noAnn a1 a2 - prim = NTKey noAnn - -test_ParamEpError :: [TestTree] -test_ParamEpError = - [ testGroup "Buildable instance" - [ testCase "Duplicated entrypoints error" $ - pretty @_ @Text (ParamEpDuplicatedNames $ unsafe (buildEpName "a") :| [DefEpName]) - @?= "Duplicated entrypoint names: 'a', ''" - , testCase "Uncallable arms error" $ - pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight]) - @?= "Due to presence of 'default' entrypoint, one of contract \"arms\" \ - \cannot be called: \"left - right\" (in top-to-bottom order)" - ] - ] - -test_contractHasEntrypoints :: [TestTree] -test_contractHasEntrypoints = - [ testCase "Simple parameter" $ - 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| or %root (int %a) (nat %b) |] - @?= Map.fromList - [ (UnsafeEpName "root", [utypeQ| or (int %a) (nat %b) |]) - , (UnsafeEpName "a", [utypeQ| int |]) - , (UnsafeEpName "b", [utypeQ| nat |]) - ] - ] - -sampleEpAddresses :: [(Text, Text)] -sampleEpAddresses = - [ ( "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo" , "01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f" ) - , ( "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar" , "01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172" ) - , ( "KT1VY2LXzHN5DJ5QWNhQykmFt26dhmsbyFwq" , "01e5d5b97aa45ee3df7218aebc5bac27b166db46a200" ) - -- TODO [https://gitlab.com/tezos/tezos/-/issues/851] and [https://gitlab.com/morley-framework/morley/-/issues/275]: - -- in Tezos almost every string is allowed to be present after '%' in address (including special - -- chars such as '{', '$', etc.) , but actual validation happens from entrypoint call, so we need - -- to investigate on it. - -- , ( "KT1VY2LXzHN5DJ5QWNhQykmFt26dhmsbyFwq%%%%" , "01e5d5b97aa45ee3df7218aebc5bac27b166db46a200252525" ) - , ( "KT1Nd2WPFZqPhzzrGJiS3e21jKjmdXxWQunk" , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000" ) - , ( "KT1Nd2WPFZqPhzzrGJiS3e21jKjmdXxWQunk%9%%" , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000392525" ) - ] - -invalidRawEpAddresses :: [Text] -invalidRawEpAddresses = - [ "" - , "qehrwu" - , "050a0000001" - , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000sd" - ] diff --git a/morley-test/Test/Ext.hs b/morley-test/Test/Ext.hs deleted file mode 100644 --- a/morley-test/Test/Ext.hs +++ /dev/null @@ -1,156 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Ext - ( test_PRINT_and_TEST_ASSERT - , test_STACKTYPE - ) where - -import Data.Default (def) -import Fmt (pretty) -import Test.HUnit (Assertion, assertFailure) -import Test.Hspec.Expectations (shouldSatisfy) -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(..), 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 () - -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 = - [ testCase "TEST_ASSERT assertion passed" $ do - runTest True c 100 100 - runTest True c 1 1 - , testCase "TEST_ASSERT assertion failed" $ do - runTest False c 0 100 - runTest False c -1 -2 - ] - - runTest corr contract x y = do - let x' = T.VInt x :: T.Value 'T.TInt - let y' = T.VInt y :: T.Value 'T.TInt - let area' = T.VInt $ x * y :: T.Value 'T.TInt - let check (a, (_, s)) = - if corr then isRight a && s == MorleyLogs ["Area is " <> pretty area'] - else isLeft a && s == MorleyLogs ["Sides are " <> pretty x' <> " x " <> pretty y'] - interpret - contract - epcPrimitive - (T.VPair (x', y')) - T.VUnit - dummyGlobalCounter - dummyBigMapCounter - dummyContractEnv - `shouldSatisfy` check - -test_STACKTYPE :: [TestTree] -test_STACKTYPE = - [ testCase "Correct test on [] pattern" $ runExtTest test1 True - , testCase "Correct test on [a, b] pattern" $ runExtTest test2 True - , testCase "Correct test on [a, b, ...] pattern" $ runExtTest test3 True - , testCase "Correct test on [a, b, ...] pattern and stack [a, b]" $ runExtTest test4 True - - , testCase "Failed test on [] pattern and stack [a]" $ runExtTest test5 False - , testCase "Failed test on [a, b] pattern and stack [a, b, c]" $ runExtTest test6 False - , testCase "Failed test on [a, b] pattern and stack [a]" $ runExtTest test7 False - , testCase "Failed test on [a, b, ...] pattern and stack [a]" $ runExtTest test8 False - , testCase "Failed test on [a, b] pattern and stack [a, c]" $ runExtTest test9 False - ] - where - p2 = StkCons (TyCon t1) (StkCons (TyCon t2) StkEmpty) - p3 = StkCons (TyCon t1) (StkCons (TyCon t2) StkRest) - - test1 = (STACKTYPE StkEmpty, convertToHST []) - test2 = (STACKTYPE p2, convertToHST [t1, t2]) - test3 = (STACKTYPE p3, convertToHST [t1, t2, t3]) - test4 = (STACKTYPE p3, convertToHST [t1, t2]) - - test5 = (STACKTYPE StkEmpty, convertToHST [t1]) - test6 = (STACKTYPE p2, convertToHST [t1, t2, t3]) - test7 = (STACKTYPE p2, convertToHST [t1]) - test8 = (STACKTYPE p3, convertToHST [t1]) - test9 = (STACKTYPE p2, convertToHST [t1, t3]) - - t1 = Ty (TOption (Ty TKey "key")) "opt" - t2 = Ty (TPair "f" "s" noAnn noAnn (Ty TUnit "x") (Ty TSignature "s")) noAnn - t3 = Ty TInt "tint" - - convertToHST :: [Ty] -> SomeHST - convertToHST [] = SomeHST SNil - convertToHST (AsUType (nt :: T.Notes t1) : ts) = - case convertToHST ts of - SomeHST is -> unsafeWithWTP @t1 $ SomeHST ((nt, T.Dict, noAnn) ::& is) - - nh (ni, si) = - typeCheckingWith def $ - runTypeCheck (TypeCheckContract $ - unsafe . mkSomeParamType $ - ParameterType (Ty TKey noAnn) noAnn) - (usingReaderT def $ - throwingTCError $ - typeCheckExt typeCheckInstr ni si) - - 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: " <> pretty e - _ -> pass diff --git a/morley-test/Test/Import.hs b/morley-test/Test/Import.hs deleted file mode 100644 --- a/morley-test/Test/Import.hs +++ /dev/null @@ -1,266 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE QuasiQuotes #-} - --- | Test on importing functionality. -module Test.Import - ( test_importContract - , test_importSomeContract - , test_importUntypedContract - , test_readContract - , test_readValue - , test_Basic - ) where - -import Control.Exception (handle) -import Data.List.NonEmpty () -import Data.Vinyl (Rec(..)) -import Test.HUnit ((@?), (@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase) - -import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos) -import Morley.Michelson.Parser (codeSrc) -import Morley.Michelson.Typed -import Morley.Michelson.Untyped qualified as U -import Morley.Util.Interpolate -import Test.Cleveland hiding (importContract, importUntypedContract) -import Test.Cleveland.Instances () -import Test.Cleveland.Michelson -import Test.Cleveland.Michelson.Import -import Test.Util.Contracts - -applyContract :: Contract ('TLambda ('TPair 'TInt 'TInt) 'TInt) 'TInt -applyContract = $$(embedContract (inContractsDir "apply.tz")) - --- | This is a clone of one of the tests but written using 'embedContract'. -test_Basic :: TestTree -test_Basic = testScenarioOnEmulator "" $ scenario do - hndl <- originateUntypedSimple "apply" (U.ValueInt 0) $ convertContract applyContract - let - lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ] - lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB - transfer TransferData - { tdTo = hndl - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = VLam $ RfNormal lam } - getStorage @Integer hndl @@== 2 - -test_readContract :: TestTree -test_readContract = testGroup "Test 'readContract'" - [ testCase emptyFilePath $ - second convertContract (readContract @'TUnit @'TUnit codeSrc emptyCode) @?= - Right emptyContractUPrim - , testCase basic2FilePath $ - second convertContract ( - readContract @TPairInt @TListPairInt codeSrc basic2Code) @?= - Right basic2ContractUPrim - , testCase basic3FilePath $ - isLeft (readContract @TPairInt @TListPairInt codeSrc basic3Code) - @? "Contract should parse" - ] - -test_importContract :: TestTree -test_importContract = testGroup "Test 'importContract'" - [ testCase emptyFilePath $ do - contract <- importContract @'TUnit @'TUnit (contractsDir emptyFilePath) - convertContract contract @?= emptyContractUPrim - , testCase basic2FilePath $ do - contract <- importContract @TPairInt @TListPairInt (contractsDir basic2FilePath) - convertContract contract @?= basic2ContractUPrim - , testCase basic3FilePath $ do - handle @ContractReadError (\_ -> pass) $ do - _ <- importContract @TPairInt @TListPairInt (contractsDir basic3FilePath) - assertFailure "No exception is raised" - ] - -test_importSomeContract :: TestTree -test_importSomeContract = testGroup "Test 'importSomeContract'" - [ testCase emptyFilePath $ do - SomeContract contract <- importSomeContract (contractsDir emptyFilePath) - convertContract contract @?= emptyContractUPrim - , testCase basic2FilePath $ do - SomeContract contract <- importSomeContract (contractsDir basic2FilePath) - convertContract contract @?= basic2ContractUPrim - , testCase basic3FilePath $ do - handle @ContractReadError (\_ -> pass) $ do - _ <- importSomeContract (contractsDir basic3FilePath) - assertFailure "No exception is raised" - ] - - -test_importUntypedContract :: TestTree -test_importUntypedContract = testGroup "Test 'importUntypedContract'" - [ testCase emptyFilePath $ do - contractU <- importUntypedContract (contractsDir emptyFilePath) - contractU @?= emptyContractU - , testCase basic2FilePath $ do - contractU <- importUntypedContract (contractsDir basic2FilePath) - contractU @?= basic2ContractU - , testCase "Non-parsable contract" $ do - handle @ContractReadError (\_ -> pass) $ do - _ <- importUntypedContract (contractsDir "unparsable" "chain_id_arity.tz") - assertFailure "No exception is raised" - ] - -test_readValue :: TestTree -test_readValue = testGroup "Test 'readValue'" - [ testCase "1" $ - (readValue @'TNat codeSrc "1") @?= Right (VNat 1) - , testCase "{1; 2}" $ - (readValue @('TList 'TString) codeSrc "{\"a\"; \"b\"}") @?= - Right (VList [VString "a", VString "b"]) - , testCase "Pair 1 \"a\"" $ - (readValue @('TPair 'TInt 'TString) codeSrc "Pair 1 \"a\"") @?= - Right (VPair (VInt 1, VString "a")) - , testCase "{something}" $ - isLeft (readValue @'TBool codeSrc "{something}") - @? "Should parse" - ] - - --- Contracts' relative filePaths - -emptyFilePath :: FilePath -emptyFilePath = "tezos_examples/attic/empty.tz" - -basic2FilePath :: FilePath -basic2FilePath = "basic2.tz" - -basic3FilePath :: FilePath -basic3FilePath = "ill-typed/basic3.tz" - - --- Text contracts - -emptyCode :: Text -emptyCode = - [itu| - parameter unit; - storage unit; - code {CDR; NIL operation; PAIR} - |] - -basic2Code :: Text -basic2Code = - [itu| - parameter (pair (int %x) (int :x)); - storage (list (pair int (int %y))); - code { - DUP; CAR; DIP { CDR; }; - CONS; - NIL operation; PAIR; }; - |] - -basic3Code :: Text -basic3Code = - [itu| - parameter (pair (int %x) int); - storage (list (pair (int %z) int)); - code { - DUP; CAR; DIP { CDR; }; - CONS; - NIL operation; PAIR; }; - |] - - --- Untyped Michelson contracts - --- We need two versions of each untyped contract for the tests. --- First is a contract which 'contractCode' is based on 'PrimEx' --- due to the fact that 'convertContract' uses this constructor --- to produce untyped contract. --- Second has 'WithSrcEx' for this purpose --- because it is a way how untyped contracts are parsed. - -emptyContractUPrim :: U.Contract -emptyContractUPrim = - U.Contract - { contractParameter = U.ParameterType U.tyunit U.noAnn - , contractStorage = U.tyunit - , contractCode = U.PrimEx <$> - [ U.CDR U.noAnn U.noAnn - , U.NIL U.noAnn U.noAnn tyoperation - , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn - ] - , entriesOrder = U.PSC - , contractViews = [] - } - -emptyContractU :: U.Contract -emptyContractU = - U.Contract - { contractParameter = U.ParameterType U.tyunit U.noAnn - , contractStorage = U.tyunit - , contractCode = - [ locExpanded 2 6 $ U.CDR U.noAnn U.noAnn - , locExpanded 2 11 $ U.NIL U.noAnn U.noAnn tyoperation - , locExpanded 2 26 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn - ] - , entriesOrder = U.PSC - , contractViews = [] - } - -basic2ContractUPrim :: U.Contract -basic2ContractUPrim = - U.Contract - { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn - , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn - , contractCode = U.PrimEx <$> - [ U.DUP U.noAnn - , U.CAR U.noAnn U.noAnn - , U.DIP [U.PrimEx $ U.CDR U.noAnn U.noAnn] - , U.CONS U.noAnn - , U.NIL U.noAnn U.noAnn tyoperation - , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn - ] - , entriesOrder = U.PSC - , contractViews = [] - } - -basic2ContractU :: U.Contract -basic2ContractU = - U.Contract - { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn - , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn - , contractCode = - [ locExpanded 7 6 $ U.DUP U.noAnn - , locExpanded 7 11 $ U.CAR U.noAnn U.noAnn - , locExpanded 7 16 $ U.DIP [locExpanded 7 22 $ U.CDR U.noAnn U.noAnn] - , locExpanded 8 6 $ U.CONS U.noAnn - , locExpanded 9 6 $ U.NIL U.noAnn U.noAnn tyoperation - , locExpanded 9 21 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn - ] - , entriesOrder = U.PSC - , contractViews = [] - } - - --- Helpers - -locExpanded :: Word -> Word -> U.ExpandedInstr -> U.ExpandedOp -locExpanded line col ei = - let noCallStack = InstrCallStack [] $ srcPos line col - in U.WithSrcEx noCallStack $ U.PrimEx ei - -locInstr :: Word -> Word -> Instr a b -> Instr a b -locInstr line col = WithLoc $ InstrCallStack [] $ srcPos line col - -withNotes - :: forall a inp out. SingI a - => Notes a - -> Instr inp (a : out) - -> Instr inp (a : out) -withNotes notes = InstrWithNotes Proxy (notes :& RNil) - -withVarAnn :: U.VarAnn -> Instr inp out -> Instr inp out -withVarAnn = InstrWithVarAnns . U.OneVarAnn - -tyoperation :: U.Ty -tyoperation = U.Ty U.TOperation U.noAnn - -type TPairInt = 'TPair 'TInt 'TInt - -type TListPairInt = 'TList ('TPair 'TInt 'TInt) diff --git a/morley-test/Test/Integrational.hs b/morley-test/Test/Integrational.hs deleted file mode 100644 --- a/morley-test/Test/Integrational.hs +++ /dev/null @@ -1,27 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for integrational testing machinery. -module Test.Integrational - ( test_Chain_id - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Runtime.GState (gsChainId, initGState) -import Morley.Michelson.Typed -import Morley.Tezos.Core -import Test.Cleveland - -type Param = () -type Storage = Maybe ChainId - -test_Chain_id :: TestTree -test_Chain_id = testScenarioOnEmulator "Chain id can be set" $ scenario do - handle <- originateTypedSimple @Param @Storage @() "get_chain_id" Nothing contract - call handle CallDefault () - getStorage handle @@== Just expectedChainId - where - contract = defaultContract @(ToT Param) @(ToT Storage) $ - DROP `Seq` CHAIN_ID `Seq` SOME `Seq` NIL `Seq` PAIR - expectedChainId = gsChainId initGState diff --git a/morley-test/Test/Interpreter.hs b/morley-test/Test/Interpreter.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter.hs +++ /dev/null @@ -1,392 +0,0 @@ --- 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 - ( test_basic5 - , test_increment - , test_fail - , test_mutez_add_overflow - , test_mutez_sub_underflow - , test_basic1 - , test_lsl - , test_lsr - , test_FAILWITH - , test_gas_exhaustion - , test_add1_list - , test_Sum_types - , test_Product_types - , test_split_bytes - , test_split_string_simple - , test_complex_strings - , test_contract_instr_on_implicit - , test_map_preserve_stack - , test_AND_binary - , test_EDIV - , test_SELF_address_packing - , test_fail_callstack - ) where - -import Fmt ((+|), (|+)) -import Hedgehog (forAll, property) -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) -import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), srcPos) -import Morley.Michelson.Text -import Morley.Michelson.Typed (IsoValue(..), divMich, modMich) -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) -import Test.Cleveland.Michelson.Import - (testTreesWithTypedContractExt, testTreesWithUntypedContractExt) - -import Test.Util.Contracts - -catchTransferFailureReason :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailureReason -catchTransferFailureReason = fmap tfReason . catchTransferFailure - -callSimple - :: forall cp st caps m. - ( HasCallStack - , MonadCleveland caps m - , HasEntrypointArg cp (EntrypointRef 'Nothing) cp - , AsRPC st ~ st - , NiceParameterFull cp, NiceStorage st - ) - => AliasHint -> T.Contract (ToT cp) (ToT st) -> cp -> st -> m st -callSimple nm contract cp st = do - handle <- originateTypedSimple @cp @st @() nm st contract - call handle CallDefault cp - getStorage handle - -callUntyped - :: forall cp st caps m. - ( MonadCleveland caps m - , T.ConstantScope (ToT st) - , AsRPC st ~ st - , NiceStorage st, NiceParameter cp - ) - => AliasHint -> U.Contract -> cp -> st -> m st -callUntyped nm contract cp st = do - handle <- originateUntypedSimple nm (T.untypeValue $ T.toVal st) contract - transfer TransferData - { tdTo = handle - , tdAmount = 0 - , tdEntrypoint = T.DefEpName - , tdParameter = cp - } - getStorage @st handle - -test_basic5 :: IO [TestTree] -test_basic5 = - testTreesWithTypedContract (contractsDir "basic5.tz") $ \contract -> pure - [ testScenarioOnEmulator "Basic test" $ scenario $ - callSimple "basic5" contract () [1] @@== [13, 100 :: Integer] - ] - -test_increment :: IO [TestTree] -test_increment = - testTreesWithTypedContract (contractsDir "increment.tz") $ \contract -> pure - [ testScenarioOnEmulator "Basic test" $ scenario $ - callSimple "increment" contract () 23 @@== (24 :: Integer) - ] - -test_fail :: IO [TestTree] -test_fail = - testTreesWithTypedContract (contractsDir "tezos_examples/macros/fail.tz") $ \contract -> pure - [ testScenarioOnEmulator "Fail test" $ scenario $ - callSimple "fail" contract () () & expectFailedWith () - ] - -test_mutez_add_overflow :: IO [TestTree] -test_mutez_add_overflow = - testTreesWithTypedContract (contractsDir "mutez_add_overflow.tz") $ \contract -> pure - [ testScenarioOnEmulator "Mutez add overflow test" $ scenario $ - callSimple "mutez_add_overflow" contract () () - & catchTransferFailureReason >>= \case - MutezArithError T.AddOverflow -> pass - _ -> failure "expecting another failure reason" - ] - -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 () () - ] - -test_basic1 :: IO [TestTree] -test_basic1 = - testTreesWithTypedContract (contractsDir "basic1.tz") $ \contract -> pure - [ testProperty "Random check" $ property $ do - input <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) - testScenarioProps $ scenario $ - callSimple "basic1" contract () input @@== [sum input + 12, 100 :: Integer] - ] - -test_lsl :: IO [TestTree] -test_lsl = - testTreesWithTypedContract (contractsDir "lsl.tz") $ \contract -> pure - [ testScenarioOnEmulator "LSL shouldn't overflow test" $ scenario $ - callSimple @Natural @Natural "lsl" contract 5 2 @@== 20 - , testScenarioOnEmulator "LSL should overflow test" $ scenario $ - callSimple "lsl" contract (5 :: Natural) (257 :: Natural) - & expectTransferFailure shiftOverflow - ] - -test_lsr :: IO [TestTree] -test_lsr = - testTreesWithTypedContract (contractsDir "lsr.tz") $ \contract -> pure - [ testScenarioOnEmulator "LSR shouldn't underflow test" $ scenario $ - callSimple @Natural @Natural "lsr" contract 30 3 @@== 3 - , testScenarioOnEmulator "LSR should underflow test" $ scenario $ - callSimple "lsr" contract (1000 :: Natural) (257 :: Natural) - & catchTransferFailureReason >>= \case - ShiftOverflow -> pass - x -> failure $ "expecting another failure reason, got " +| x |+ "" - ] - -test_FAILWITH :: IO [TestTree] -test_FAILWITH = concatTestTrees - [ testTreesWithTypedContract (contractsDir "failwith_message.tz") $ \contract -> - pure - [ testScenarioOnEmulator "Failwith message test" $ scenario $ - let msg = "An error occurred." :: MText - in callSimple "failwith_message" contract msg () - & expectFailedWith msg - ] - , testTreesWithTypedContract (contractsDir "failwith_message2.tz") $ \contract -> - pure - [ testScenarioOnEmulator "Conditional failwith message test" $ scenario do - let msg = "An error occurred." :: MText - callSimple "failwith_message2" contract (True, msg) () - & expectFailedWith msg - - , testScenarioOnEmulator "Conditional success test" $ scenario do - let param = (False, "Err" :: MText) - callSimple "failwith_message2" contract param () - ] - ] - -test_gas_exhaustion :: IO [TestTree] -test_gas_exhaustion = - testTreesWithTypedContract (contractsDir "gas_exhaustion.tz") $ \contract -> pure - [ testScenarioOnEmulator "Contract should fail due to gas exhaustion" $ scenario $ - let dummyStr = "x" :: MText - in callSimple "gas_exhaustion" contract dummyStr dummyStr - & catchTransferFailureReason >>= \case - GasExhaustion -> pass - e -> failure $ "Expected gas_exhaustion, but got " +| e |+ "" - ] - -test_fail_callstack :: IO [TestTree] -test_fail_callstack = - 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) -> - ics @== InstrCallStack { - icsCallStack = map LetName ["letfail1", "letfail2", "letfail3"] - , icsSrcPos = srcPos 5 29 - } - err -> failure $ - "Expected interpreter to fail with callstack, but it instead errored with " +| - err |+ "" - ] - -test_add1_list :: IO [TestTree] -test_add1_list = - testTreesWithTypedContract (contractsDir "tezos_examples/attic/add1_list.tz") $ \contract -> - pure - [ testProperty "Random check" $ property $ do - param <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) - testScenarioProps $ scenario $ - callSimple @[Integer] @[Integer] "add1_list" contract param param @@== map succ param - ] - -test_Sum_types :: IO [TestTree] -test_Sum_types = concatTestTrees - [ testTreesWithUntypedContractExt (contractsDir "union.mtz") $ \contract -> pure - [ testGroup "union.mtz: union corresponds to Haskell types properly" $ - let caseTest param = scenario $ callUntyped "union" contract param () - in - [ testScenarioOnEmulator "Case 1" $ caseTest (Case1 3) - , testScenarioOnEmulator "Case 2" $ caseTest (Case2 "a") - , testScenarioOnEmulator "Case 3" $ caseTest (Case3 $ Just "b") - , testScenarioOnEmulator "Case 4" $ caseTest (Case4 $ Left "b") - , testScenarioOnEmulator "Case 5" $ caseTest (Case5 ["q"]) - ] - ] - , testTreesWithUntypedContractExt (contractsDir "case.mtz") $ \contract -> pure - [ testGroup "CASE instruction" $ - let caseTest param expectedStorage = scenario $ - callUntyped "case" contract param ("" :: MText) - @@== expectedStorage - in - [ testScenarioOnEmulator "Case 1" $ caseTest (Case1 5) "int" - , testScenarioOnEmulator "Case 2" $ caseTest (Case2 "a") "string" - , testScenarioOnEmulator "Case 3" $ caseTest (Case3 $ Just "aa") "aa" - , testScenarioOnEmulator "Case 4" $ caseTest (Case4 $ Right "b") "or string string" - , testScenarioOnEmulator "Case 5" $ caseTest (Case5 $ ["a", "b"]) "ab" - ] - ] - , 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 - ] - ] - -test_Product_types :: IO [TestTree] -test_Product_types = concatTestTrees - [ testTreesWithTypedContractExt (contractsDir "access.mtz") $ \contract -> pure - [ testScenarioOnEmulator "ACCESS instruction" $ scenario $ - callSimple @Tuple1 "access" contract (1, "a", Just "a", Right "a", ["a"]) () - ] - , 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 - ] - , 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 - ] - ] - -test_split_bytes :: IO [TestTree] -test_split_bytes = - testTreesWithTypedContract (contractsDir "tezos_examples/opcodes/split_bytes.tz") $ - \contract -> pure - [ testScenarioOnEmulator "splits given byte sequence into parts" $ scenario $ - let expected = ["\11", "\12", "\13"] :: [ByteString] - in callSimple "split_bytes" contract ("\11\12\13" :: ByteString) ([] :: [ByteString]) - @@== expected - ] - -test_split_string_simple :: IO [TestTree] -test_split_string_simple = - testTreesWithTypedContract (contractsDir "split_string_simple.tz") $ \contract -> - pure - [ testScenarioOnEmulator "applies SLICE instruction" $ scenario do - let - oneTest o l str expected = - callSimple @(Natural, Natural) @(Maybe MText) "split_string_simple" - contract (o, l) (Just str) @@== expected - - -- These values have been tested using tezos-client - oneTest 0 0 "aaa" (Just "") - oneTest 2 0 "aaa" (Just "") - oneTest 3 0 "aaa" Nothing - oneTest 0 5 "aaa" Nothing - oneTest 1 2 "abc" (Just "bc") - oneTest 1 1 "abc" (Just "b") - oneTest 2 1 "abc" (Just "c") - oneTest 2 2 "abc" Nothing - oneTest 1 1 "\"\"" (Just "\"") - oneTest 1 2 "a\n" Nothing - ] - -test_complex_strings :: IO [TestTree] -test_complex_strings = - testTreesWithTypedContract (contractsDir "complex_strings.tz") $ \contract -> - pure - [ testScenarioOnEmulator "ComplexString" $ scenario $ - callSimple "complex_strings" contract ("text: " :: MText) ("" :: MText) - @@== ("text: \"aa\" \\\n" :: MText) - ] - -data Union1 - = Case1 Integer - | Case2 MText - | Case3 (Maybe MText) - | Case4 (Either MText MText) - | Case5 [MText] - deriving stock (Generic) - deriving anyclass (IsoValue) - -type Tuple1 = (Integer, MText, Maybe MText, Either MText MText, [MText]) - -test_contract_instr_on_implicit :: IO [TestTree] -test_contract_instr_on_implicit = - testTreesWithTypedContract (contractsDir "contract_instr_unit.tz") $ \contractGood -> - testTreesWithTypedContract (contractsDir "contract_instr_nonunit.tz") $ \contractBad -> - pure - [ testScenarioOnEmulator "CONTRACT instruction succeeds on implicit accounts" $ scenario $ - callSimple "contract_instr_unit" contractGood addr () - - , testScenarioOnEmulator "CONTRACT instruction considers implicit accounts as unit-parametrized" $ - scenario $ callSimple "contract_instr_nounit" contractBad addr () - & expectFailedWith ("No such contract" :: MText) - ] - where - addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf" - --- | This test creates a map of two items and then converts them into a list --- with @MAP@ primitive, counting the number of items along the way. --- --- See https://gitlab.com/morley-framework/morley/-/issues/123 -test_map_preserve_stack :: IO [TestTree] -test_map_preserve_stack = - testTreesWithTypedContract (contractsDir "map_preserve_stack.tz") $ \contract -> - pure - [ testScenarioOnEmulator "MAP preserves deep stack modifications (#123)" $ scenario $ - callSimple @() @([Integer], Integer) "map_preserve_stack" contract () ([], 0) - @@== ([257, 43], 2) - ] - -test_AND_binary :: IO [TestTree] -test_AND_binary = - testTreesWithTypedContract (contractsDir "tezos_examples/opcodes/and_binary.tz") $ \contract -> - pure - [ testScenarioOnEmulator "Binary AND test" $ scenario $ - callSimple "and_binary" contract () () - ] - -type TestEdivStorage = - ( Maybe (Integer, Natural) - , ( Maybe (Integer, Natural) - , ( Maybe (Integer, Natural) - , Maybe (Natural, Natural) - ) - ) - ) - -test_EDIV :: IO [TestTree] -test_EDIV = - testTreesWithTypedContract (contractsDir "tezos_examples/opcodes/ediv.tz") $ \contract -> - pure - [ testScenarioOnEmulator "EDIV of int and nat test (non-zero modulo)" $ scenario $ - let intNatNeg = (278 `divMich` -167, fromInteger $ (278 `modMich` -167)) - intNatPos = (278 `divMich` 167, 278 `modMich` 167) - natNat = (278 `divMich` 167, 278 `modMich` 167) - in callSimple @(Integer, Integer) @TestEdivStorage "ediv" contract - (278, -167) (Nothing, (Nothing, (Nothing, Nothing))) - @@== (Just intNatNeg, (Just intNatPos, (Just intNatNeg, Just natNat))) - , testScenarioOnEmulator "EDIV of int and nat test (zero modulo)" $ scenario $ - callSimple @(Integer, Integer) @TestEdivStorage "ediv" contract - (109, -1) (Nothing, (Nothing, (Nothing, Nothing))) - @@== (Just (-109, 0), (Just (109, 0), (Just (-109, 0), Just (109, 0)))) - ] - -test_SELF_address_packing :: IO [TestTree] -test_SELF_address_packing = - testTreesWithTypedContract (contractsDir "entrypoints/self_pack1.tz") $ \contract -> - pure - [ testScenarioOnEmulator "SELF address packing (#333)" $ scenario $ - callSimple "self_pack1" contract () () - ] diff --git a/morley-test/Test/Interpreter/Annotations.hs b/morley-test/Test/Interpreter/Annotations.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Annotations.hs +++ /dev/null @@ -1,1055 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Interpreter.Annotations - ( test_cast_notes - , test_complex_instructions_notes - , test_interpret_stack - , test_update_notes - , test_create_contract_notes - , unit_PAIRN_doesnt_convert_anns_but_UNPAIRN_does - , unit_GETN_adds_var_ann - , unit_GET_0_deletes_var_ann - , unit_UPDATEN_field_anns - , unit_UPDATEN_var_anns - , unit_GET_AND_UPDATE_anns - , test_dupn - , test_nested_annots - , unit_CARk_CDRk_interact_with_annotations - , unit_CAR_special_annotations - , unit_CDR_special_annotations - , unit_UNPAIR_special_annotations - , 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 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) -import Fmt (pretty) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase) - -import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos) -import Morley.Michelson.Interpret - (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 Morley.Michelson.Typed qualified as T -import Morley.Michelson.Untyped (noAnn) -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 Text.Show qualified - -import Test.Util.Contracts (contractsDir, ()) - -data SomeStackElem = forall t. SomeStackElem (StkEl t) - -instance Eq SomeStackElem where - SomeStackElem (StkEl v1 vn1 n1) == SomeStackElem (StkEl v2 vn2 n2) = - v1 `T.eqValueExt` v2 - && vn1 == vn2 - && T.withValueTypeSanity v1 (T.withValueTypeSanity v2 (n1 `eqParamSing` n2)) - -data SomeStack where - SomeStack :: forall s. Rec StkEl s -> SomeStack - -instance Show SomeStack where - show (SomeStack v) = case v of - RNil -> "[]" - x :& xs -> Debug.show x <> " :& " <> Debug.show (SomeStack xs) - -instance Eq SomeStack where - a == b = stackToElems a == stackToElems b - where - stackToElems :: SomeStack -> [SomeStackElem] - stackToElems (SomeStack stack) = recordToList $ rmap (Const . SomeStackElem) stack - -data TestInterpreterState = TestInterpreterState - { _tisInterpreterState :: InterpreterState - , _tisStacks :: [Maybe SomeStack] - -- ^ A list of the stacks we expect to see after running each instruction. - -- Use 'Nothing' when you don't care what the stack looks like at that step. - } - -makeLensesFor [("_tisStacks", "tisStacks")] ''TestInterpreterState - -someStack :: Rec StkEl s -> Maybe SomeStack -someStack = Just . SomeStack - -ignoreStack :: Maybe SomeStack -ignoreStack = Nothing - -instance (Monad m, Monoid w) => InterpreterStateMonad (RWST r w TestInterpreterState m) where - stateInterpreterState f = state - (\TestInterpreterState{..} -> - let (a, newSt) = f _tisInterpreterState in (a, TestInterpreterState{_tisInterpreterState=newSt,..})) - -type TestInstrRunner = InstrRunner (ExceptT MichelsonFailureWithStack $ RWST ContractEnv MorleyLogsBuilder TestInterpreterState IO) - -runInstrTest :: HasCallStack => TestInstrRunner -runInstrTest = runInstrTestImpl False - -runInstrTestImpl :: HasCallStack => Bool -> TestInstrRunner -runInstrTestImpl skipInstr instr stack = do - actualStack <- runInstrImpl (runInstrTestImpl $ isAnnotated instr) instr stack - when (isRealInstr instr && not skipInstr) do - (tisStacks <<%= Unsafe.tail) <&> Unsafe.head >>= \case - Nothing -> - -- We don't care what the stack looks like at this step, so we do nothing here. - pass - Just expectedStack -> - -- We care what the stack looks like at this step, - -- so we check whether it matches our expectation. - liftIO $ - assertEqual - (List.unlines - [ "Actual stack did not match the expected stack after running this instruction:" - , " " <> pretty (T.instrToOps instr) - ] - ) - expectedStack - (SomeStack actualStack) - pure actualStack - -isAnnotated :: T.Instr a b -> Bool -isAnnotated = \case - T.InstrWithVarNotes{} -> True - T.InstrWithVarAnns{} -> True - T.InstrWithNotes{} -> True - _ -> False - -isRealInstr :: T.Instr a b -> Bool -isRealInstr = \case - T.DocGroup{} -> False - T.Seq{} -> False - T.Nop -> False - T.WithLoc{} -> False - T.Nested{} -> False - _ -> True - -stackAnnotationsTest - :: HasCallStack - => String - -> Rec StkEl (T.ContractInp cp st) - -> [Maybe SomeStack] - -> T.Contract cp st - -> TestTree -stackAnnotationsTest description initialStack expectedStacks contract = - testCase description $ - stackAnnotationsAssertion initialStack expectedStacks contract - -stackAnnotationsAssertion - :: HasCallStack - => Rec StkEl (T.ContractInp cp st) - -> [Maybe SomeStack] - -> T.Contract cp st - -> Assertion -stackAnnotationsAssertion initialStack expectedStacks contract = do - let initialState = - TestInterpreterState - (initInterpreterState dummyGlobalCounter dummyBigMapCounter dummyContractEnv) - expectedStacks - let action = runInstrImpl runInstrTest (T.cCode contract) initialStack - (result, finalState, _logs) <- runRWST (runExceptT action) dummyContractEnv initialState - - assertEqual - "Finished interpreting contract, but we still expected more instructions to be run." - [] - (finalState ^. tisStacks) - - whenLeft result (assertFailure . pretty) - -ops :: T.Value ('T.TList 'T.TOperation) -ops = T.VList [] - -test_complex_instructions_notes :: IO [TestTree] -test_complex_instructions_notes = concat <$> sequenceA - [ importContract (contractsDir "if-none-annots.tz") <&> \contract -> - [ stackAnnotationsTest - "IF_NONE preserves its annotations with None (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VOption Nothing, T.VInt 0)) :& RNil) - expectedStacksIF_NONE_None - contract - , stackAnnotationsTest - "IF_NONE preserves its annotations with Some (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VOption $ Just $ T.VInt 6, T.VInt 0)) :& RNil) - expectedStacksIF_NONE_Some - contract - ] - , importContract (contractsDir "if-left-annots.tz") <&> \contract -> - [ stackAnnotationsTest - "IF_LEFT preserves its annotations with Left (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VOr $ Left $ T.VInt 6, T.VInt 0)) :& RNil) - expectedStacksIF_LEFT_Left - contract - , stackAnnotationsTest - "IF_LEFT preserves its annotations with Right (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VOr $ Right $ T.VInt 7, T.VInt 0)) :& RNil) - expectedStacksIF_LEFT_Right - contract - ] - , importContract (contractsDir "if-cons-annots.tz") <&> \contract -> - [ stackAnnotationsTest - "IF_CONS preserves its annotations with {10} (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VList [T.VInt 10], T.VInt 0)) :& RNil) - expectedStacksIF_CONS_Cons - contract - , stackAnnotationsTest - "IF_CONS preserves its annotations with {} (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VList [], T.VInt 0)) :& RNil) - expectedStacksIF_CONS_Nil - contract - ] - ] - where - y :: T.Notes 'T.TInt - y = [notes|int :y|] - - param = "parameter" - - expectedStacksIF_NONE_None :: [Maybe SomeStack] - expectedStacksIF_NONE_None = - [ -- CAR - 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 - , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil - -- NIL operation - -- PAIR - , ignoreStack, ignoreStack - ] - - expectedStacksIF_NONE_Some :: [Maybe SomeStack] - expectedStacksIF_NONE_Some = - [ -- CAR - 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 - , someStack $ StkEl (T.VInt 7) U.noAnn y :& RNil - -- IF_NONE - , someStack $ StkEl (T.VInt 7) U.noAnn y :& RNil - -- NIL operation - -- PAIR - , ignoreStack, ignoreStack - ] - - expectedStacksIF_LEFT_Left :: [Maybe SomeStack] - expectedStacksIF_LEFT_Left = - [ -- CAR - 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 - , someStack $ StkEl (T.VInt 7) U.noAnn y :& RNil - -- IF_LEFT - , someStack $ StkEl (T.VInt 7) U.noAnn y :& RNil - -- NIL operation - -- PAIR - , ignoreStack, ignoreStack - ] - - expectedStacksIF_LEFT_Right :: [Maybe SomeStack] - expectedStacksIF_LEFT_Right = - [ -- CAR - 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 - , someStack $ StkEl (T.VInt 9) U.noAnn y :& RNil - -- IF_LEFT - , someStack $ StkEl (T.VInt 9) U.noAnn y :& RNil - -- NIL operation - -- PAIR - , ignoreStack, ignoreStack - ] - - expectedStacksIF_CONS_Cons :: [Maybe SomeStack] - expectedStacksIF_CONS_Cons = - [ -- CAR - someStack $ StkEl (T.VList [T.VInt 10]) param [notes|list (int :y)|] :& RNil - -- DROP - , someStack $ RNil - -- DIP - , someStack $ StkEl (T.VInt 10) param y :& RNil - -- IF_CONS - , someStack $ StkEl (T.VInt 10) param y :& RNil - -- NIL operation - -- TODO: This param should not be here, probably related to #507 - , someStack $ starNotesStkEl ops :& StkEl (T.VInt 10) param y :& RNil - -- PAIR - , ignoreStack - ] - - expectedStacksIF_CONS_Nil :: [Maybe SomeStack] - expectedStacksIF_CONS_Nil = - [ -- CAR - 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 - , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil - -- NIL operation - -- PAIR - , ignoreStack, ignoreStack - ] - -test_cast_notes :: IO [TestTree] -test_cast_notes = sequenceA - [ importContract (contractsDir "cast-annots.tz") <&> - stackAnnotationsTest - "CAST can remove and add annotations (morley-debugger#2, morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VUnit, T.VPair (T.VInt 0, T.VInt 0))) :& RNil) - expectedStacksCast - ] - where - notesPair :: T.Notes ('T.TPair 'T.TInt 'T.TInt) - 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) - - expectedStacksCast :: [Maybe SomeStack] - expectedStacksCast = - [ -- DROP - someStack RNil - -- PUSH @ab (pair :p (int :a) (int :b)) (Pair 1 2) - , someStack $ StkEl - pair - "ab" - [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)) - , someStack $ StkEl pair "xy" notesPair :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ StkEl (T.VPair (ops, pair)) noAnn (NTPair noAnn noAnn noAnn noAnn "xy" starNotes notesPair) :& RNil - ] - -test_interpret_stack :: IO [TestTree] -test_interpret_stack = sequenceA - [ importContract (contractsDir "loop-annots.tz") <&> - stackAnnotationsTest - "Annotations should be preserved in LOOP (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VUnit, T.VInt 0)) :& RNil) - expectedStacksLoop - , importContract (contractsDir "map-annots.tz") <&> - stackAnnotationsTest - "Annotations should be preserved in MAP (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VUnit, T.VInt 0)) :& RNil) - expectedStacksMap - ] - where - q :: T.Notes 'T.TInt - q = [notes|int :q|] - - qv :: U.VarAnn - qv = "q" - - expectedStacksLoop :: [Maybe SomeStack] - expectedStacksLoop = - [ -- DROP - someStack RNil - -- PUSH @q (int :q) 2 - , someStack $ StkEl (T.VInt 2) qv q :& RNil - -- PUSH bool True - , someStack $ starNotesStkEl (T.VBool True) :& StkEl (T.VInt 2) qv q :& RNil - -- CAST int - , someStack $ StkEl (T.VInt 2) qv T.starNotes :& RNil - -- RENAME - , someStack $ starNotesStkEl (T.VInt 2) :& RNil - -- PUSH int -1 - , someStack $ starNotesStkEl (T.VInt (-1)) :& starNotesStkEl (T.VInt 2) :& RNil - -- ADD - , someStack $ starNotesStkEl (T.VInt 1) :& RNil - -- DUP - , someStack $ starNotesStkEl (T.VInt 1) :& starNotesStkEl (T.VInt 1) :& RNil - -- GT - , someStack $ starNotesStkEl (T.VBool True) :& starNotesStkEl (T.VInt 1) :& RNil - -- CAST int - , someStack $ StkEl (T.VInt 1) qv T.starNotes :& RNil - -- RENAME - , someStack $ starNotesStkEl (T.VInt 1) :& RNil - -- PUSH int -1 - , someStack $ starNotesStkEl (T.VInt (-1)) :& starNotesStkEl (T.VInt 1) :& RNil - -- ADD - , someStack $ starNotesStkEl (T.VInt 0) :& RNil - -- DUP - , someStack $ starNotesStkEl (T.VInt 0) :& starNotesStkEl (T.VInt 0) :& RNil - -- GT - , someStack $ starNotesStkEl (T.VBool False) :& starNotesStkEl (T.VInt 0) :& RNil - -- n.b.: these LOOP instructions are an implementation detail in Morley - -- and do not appear in tezos-client while running an script with the - -- --trace-stack flag. - -- LOOP - , someStack $ StkEl (T.VInt 0) U.noAnn T.starNotes :& RNil - -- LOOP - , someStack $ StkEl (T.VInt 0) U.noAnn T.starNotes :& RNil - -- LOOP - , someStack $ StkEl (T.VInt 0) qv q :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ StkEl (T.VPair (ops, T.VInt 0)) noAnn (NTPair noAnn noAnn noAnn noAnn "q" starNotes q) :& RNil - ] - - y :: T.Notes 'T.TInt - y = [notes|int :y|] - - yv :: U.VarAnn - yv = "y" - - expectedStacksMap :: [Maybe SomeStack] - expectedStacksMap = - [ -- DROP - someStack $ RNil - -- 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]) "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 - , someStack $ StkEl (T.VInt 42) yv T.starNotes :& RNil - -- DIP - , someStack $ StkEl (T.VInt 1) qv q :& StkEl (T.VInt 42) yv T.starNotes :& RNil - -- CAST @q (int :q) - , someStack $ StkEl (T.VInt 10) qv q :& StkEl (T.VInt 42) yv T.starNotes :& RNil - -- CAST int - , someStack $ StkEl (T.VInt 42) yv T.starNotes :& RNil - -- 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 [notes|list (int :q)|] :& StkEl (T.VInt 42) yv T.starNotes :& RNil - -- DROP - , someStack $ StkEl (T.VInt 42) yv T.starNotes :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ StkEl (T.VPair (ops, T.VInt 42)) noAnn (NTPair noAnn noAnn noAnn noAnn yv starNotes starNotes) :& RNil - ] - -test_update_notes :: IO [TestTree] -test_update_notes = sequenceA - [ importContract (contractsDir "update-annots.tz") <&> - stackAnnotationsTest - "UPDATE keeps its annotations (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VUnit, T.VMap @'T.TInt @'T.TInt Map.empty)) :& RNil) - expectedStacksUpdate - ] - where - m :: T.Notes ('T.TMap 'T.TInt 'T.TInt) - m = [notes|map :m (int :k) (int :v)|] - - k :: T.Notes 'T.TInt - k = [notes|int :k|] - - v :: T.Notes ('T.TOption 'T.TInt) - v = [notes|option (int :v)|] - - mv, kv, vv :: U.VarAnn - mv = "m" - kv = "k" - vv = "v" - - intMap :: T.Value ('T.TMap 'T.TInt 'T.TInt) - intMap = T.VMap $ Map.fromList [(T.VInt 0, T.VInt 1), (T.VInt 1, T.VInt 2), (T.VInt 2, T.VInt 0)] - - intMap' :: T.Value ('T.TMap 'T.TInt 'T.TInt) - intMap' = T.VMap $ Map.fromList [(T.VInt 0, T.VInt 1), (T.VInt 1, T.VInt 2)] - - expectedStacksUpdate :: [Maybe SomeStack] - expectedStacksUpdate = - [ -- DROP - someStack RNil - -- PUSH @s (map :m int int) {Elt 0 1; Elt 1 2; Elt 2 0} - , someStack $ StkEl intMap mv m :& RNil - -- NONE @v (int :v) - , someStack $ StkEl (T.VOption Nothing) vv v :& StkEl intMap mv m :& RNil - -- PUSH @k (int :k) 2 - , someStack $ StkEl (T.VInt 2) kv k :& StkEl (T.VOption Nothing) vv v :& StkEl intMap mv m :& RNil - -- UPDATE - , someStack $ StkEl intMap' mv m :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ StkEl (T.VPair (ops, intMap')) noAnn (NTPair noAnn noAnn noAnn noAnn "m" starNotes m) :& RNil - ] - -test_create_contract_notes :: IO [TestTree] -test_create_contract_notes = sequenceA - [ importContract (contractsDir "create-contract-annots.tz") <&> - stackAnnotationsTest - "CREATE_CONTRACT produces two annotations (morley-debugger#4)" - (starNotesStkEl (T.VPair (T.VUnit, storage)) :& RNil) - expectedStacksCreateContract - ] - where - address :: Address - address = unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD" - - storage :: T.Value 'T.TAddress - storage = T.VAddress $ T.EpAddress address T.DefEpName - - op :: T.Value ('T.TOption 'T.TKeyHash) - op = T.VOption Nothing - - mutez :: T.Value 'T.TMutez - mutez = T.VMutez 100 - - contract :: T.Value 'T.TOperation - contract = T.VOp $ T.OpCreateContract T.CreateContract - { T.ccOriginator = genesisAddress - , T.ccDelegate = Nothing - , T.ccBalance = 100 - , T.ccStorageVal = T.VUnit - , T.ccContract = T.defaultContract $ - let loc c = T.WithLoc $ InstrCallStack [] $ srcPos 12 c in - loc 19 T.CDR - `T.Seq` loc 24 T.NIL - `T.Seq` loc 39 T.PAIR :: T.Instr (T.ContractInp 'T.TUnit 'T.TUnit) (T.ContractOut 'T.TUnit) - , T.ccCounter = 1 - } - - expectedStacksCreateContract :: [Maybe SomeStack] - expectedStacksCreateContract = - [ -- DROP - someStack RNil - , -- UNIT - someStack $ starNotesStkEl T.VUnit :& RNil - , -- AMOUNT - someStack $ starNotesStkEl mutez :& starNotesStkEl T.VUnit :& RNil - , -- NONE key_hash - someStack $ starNotesStkEl op :& starNotesStkEl mutez :& starNotesStkEl T.VUnit :& RNil - , -- CREATE_CONTRACT @op @addr - someStack $ StkEl contract "op" T.starNotes :& StkEl storage "addr" T.starNotes :& RNil - , -- NIL operation - someStack $ starNotesStkEl ops :& StkEl contract "op" T.starNotes :& StkEl storage "addr" T.starNotes :& RNil - , -- SWAP - someStack $ StkEl contract "op" T.starNotes :& starNotesStkEl ops :& StkEl storage "addr" T.starNotes :& RNil - , -- CONS - someStack $ starNotesStkEl (T.VList [contract]) :& StkEl storage "addr" T.starNotes :& RNil - , -- PAIR - someStack $ StkEl (T.VPair (T.VList [contract], storage)) noAnn (NTPair noAnn noAnn noAnn noAnn "addr" starNotes starNotes) :& RNil - ] - -unit_PAIRN_doesnt_convert_anns_but_UNPAIRN_does :: Assertion -unit_PAIRN_doesnt_convert_anns_but_UNPAIRN_does = do - contract <- importContract (contractsDir "pair_n_unpair_n.tz") - stackAnnotationsAssertion - (StkEl contractInput noAnn contractInputNotes :& RNil) - expectedStacks - contract - where - pairNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] - - pairNotes' = [notes|pair (int :a) (int :b) (int :c)|] - - paramN = "parameter" - - storage = (1, (2, 3)) :: (Integer, (Integer, Integer)) - param = (4, (5, 6)) :: (Integer, (Integer, Integer)) - contractInput = toVal (param, storage) - contractInputNotes = - NTPair - noAnn noAnn noAnn paramN noAnn - pairNotes -- parameter - pairNotes -- storage - - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- CAR - someStack $ - StkEl (toVal param) paramN pairNotes :& - RNil - -- UNPAIR 3 - , someStack $ - 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 $ - StkEl (toVal param) "newStorage" pairNotes' :& - RNil - -- NIL operation; - , someStack $ - starNotesStkEl ops :& - StkEl (toVal param) "newStorage" pairNotes' :& - RNil - -- PAIR 2; - , someStack $ - StkEl - (toVal ([] :: [Operation], param)) - noAnn - (NTPair noAnn noAnn noAnn noAnn noAnn starNotes pairNotes') :& - RNil - ] - -unit_GETN_adds_var_ann :: Assertion -unit_GETN_adds_var_ann = do - contract <- importContract (contractsDir "get_n.tz") - stackAnnotationsAssertion - (StkEl contractInput noAnn contractInputNotes :& RNil) - expectedStacks - contract - where - paramNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] - - storageNotes = [notes|pair (int :a %aa) (int :b %bb)|] - - storage = (5, 6) :: (Integer, Integer) - param = (1, (2, 3)) :: (Integer, (Integer, Integer)) - contractInput = toVal (param, storage) - contractInputNotes = - NTPair - noAnn noAnn noAnn "parameter" "storage" - paramNotes - storageNotes - - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- CAR - ignoreStack - -- DUP - , someStack $ - StkEl (toVal param) "parameter" paramNotes :& - StkEl (toVal param) "parameter" paramNotes :& - RNil - -- GET 3; - , someStack $ - 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 [notes|int :b|] :& - RNil - -- GET @aa 1 - , someStack $ - StkEl (toVal @Integer 1) "aa" [notes|int :a|] :& - StkEl (toVal @Integer 2) noAnn [notes|int :b|] :& - RNil - -- PAIR 2 - -- NIL operation; - -- PAIR 2; - , ignoreStack, ignoreStack, ignoreStack - ] - -unit_GET_0_deletes_var_ann :: Assertion -unit_GET_0_deletes_var_ann = do - contract <- importContract (contractsDir "get_0.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), 0 :: Integer)) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- DROP - ignoreStack - -- PUSH @var (int :i) 1 - , someStack $ - StkEl (toVal @Integer 1) "var" [notes|int :i|] :& - RNil - -- GET 0; - , someStack $ - StkEl (toVal @Integer 1) noAnn [notes|int :i|] :& - RNil - -- NIL operation; - -- PAIR 2; - , ignoreStack, ignoreStack - ] - -unit_UPDATEN_field_anns :: Assertion -unit_UPDATEN_field_anns = do - contract <- importContract (contractsDir "update_n_field_anns.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), (0 :: Natural, 0 :: Natural))) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- DROP - ignoreStack - -- PUSH (pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) { 0; "a"; Unit }; - , someStack $ - StkEl - (toVal (0 :: Integer, ("a" :: MText, ()))) - noAnn - [notes|(pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3))|] :& - RNil - - -- PUSH (nat :t4) 0; UPDATE 1; - -- PUSH (nat :t5) 0; UPDATE 3; - -- PUSH (nat :t6) 0; UPDATE 4; - , ignoreStack, ignoreStack - , ignoreStack, ignoreStack - , ignoreStack - , someStack $ - StkEl - (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural))) - noAnn - [notes|(pair :t0 (nat :t4 %f1) (nat :t5 %f2) (nat :t6 %f3))|] :& - RNil - - -- PUSH (pair (nat :t7 %f7) (nat :t8 %f8)) (Pair 0 0); - -- UPDATE 2; - , ignoreStack - , someStack $ - StkEl - (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural))) - noAnn - [notes|pair :t0 (nat :t4 %f1) (nat :t7 %f7) (nat :t8 %f8)|] :& - RNil - - -- PUSH (nat :t9) 0; - -- UPDATE 2; - , ignoreStack - , someStack $ - StkEl - (toVal (0 :: Natural, 0 :: Natural)) - noAnn - [notes|pair :t0 (nat :t4 %f1) (nat :t9)|] :& - RNil - -- NIL operation; PAIR; - , ignoreStack, ignoreStack - ] - -unit_UPDATEN_var_anns :: Assertion -unit_UPDATEN_var_anns = do - contract <- importContract (contractsDir "update_n_var_anns.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), (0 :: Integer, 0 :: Integer))) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- DROP; - -- PUSH @v1 (pair int int) (Pair 0 0); - -- PUSH @v2 int 0; - ignoreStack, ignoreStack - , someStack $ - StkEl (toVal (0 :: Integer)) "v2" starNotes :& - StkEl (toVal (0 :: Integer, 0 :: Integer)) "v1" starNotes :& - RNil - - -- UPDATE 1 - , someStack $ - StkEl (toVal (0 :: Integer, 0 :: Integer)) "" starNotes :& - RNil - - -- PUSH int 0; - -- UPDATE @v3 1; - , ignoreStack - , someStack $ - StkEl (toVal (0 :: Integer, 0 :: Integer)) "v3" starNotes :& - RNil - - -- NIL operation; PAIR; - , ignoreStack, ignoreStack - ] - -unit_GET_AND_UPDATE_anns :: Assertion -unit_GET_AND_UPDATE_anns = do - contract <- importContract (contractsDir "get_and_update_anns.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), ())) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- DROP; - -- EMPTY_MAP :map @varMap (int :k) (nat :v); - -- PUSH @varVal (option (nat :v)) (Some 1); - -- PUSH @varKey (int :k) 1; - ignoreStack, ignoreStack, ignoreStack, ignoreStack - - -- GET_AND_UPDATE - , someStack $ - 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" [notes|option (nat :v)|] :& - StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" [notes|map :map (int :k) (nat :v)|] :& - RNil - - -- DROP 2; - -- UNIT; NIL operation; PAIR - , ignoreStack, ignoreStack, ignoreStack, ignoreStack - ] - -test_dupn :: IO TestTree -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 [notes|pair unit (int :x)|] :& RNil) - expectedStacks - where - store :: T.Value 'T.TInt - store = T.VInt 42 - - x :: T.Notes 'T.TInt - x = [notes|int :x|] - - kek :: T.Value 'T.TString - kek = T.VString "kek" - - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- CDR - someStack $ StkEl store "storage" x :& RNil - -- RENAME @x - , someStack $ StkEl store "x" x :& RNil - -- PUSH string "kek" - , someStack $ starNotesStkEl kek :& StkEl store "x" x :& RNil - -- DUP 2 - -- n.b.: DUP n doesn't duplicate variable annotations. This is consistent with tezos-client. - , someStack $ StkEl store U.noAnn x :& starNotesStkEl kek :& StkEl store "x" x :& RNil - -- SWAP - , someStack $ starNotesStkEl kek :& StkEl store U.noAnn x :& StkEl store "x" x :& RNil - -- DROP 2 - , someStack $ StkEl store "x" x :& RNil - -- DUP @z 1 - , someStack $ StkEl store "z" x :& StkEl store "x" x :& RNil - -- DROP - , someStack $ StkEl store "x" x :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ StkEl (VPair (ops, store)) noAnn (NTPair noAnn noAnn noAnn noAnn "x" starNotes x) :& RNil - ] - -test_nested_annots :: IO [TestTree] -test_nested_annots = sequenceA - [ importContract (contractsDir "nested-pair-annots.tz") <&> - stackAnnotationsTest - "CAR interacts with annotations (morley-debugger#13)" - (mkInitStack (VNat 1) starParamNotes (VNat 2) starNotes) - expectedStacks1 - , importContract (contractsDir "nested-pair-annots-2.tz") <&> - stackAnnotationsTest - "CAR @a overrides annotations (morley-debugger#13)" - (mkInitStack (VNat 1) starParamNotes (VNat 2) starNotes) - expectedStacks2 - ] - where - parameterStk = StkEl (VNat 1) "parameter" starNotes - - storageStk = StkEl (VNat 2) "storage" starNotes - - expectedStacks1 :: [Maybe SomeStack] - expectedStacks1 = - [ -- UNPAIR - someStack $ parameterStk :& storageStk :& RNil - -- UNIT @something - , someStack $ - StkEl VUnit "something" starNotes :& - parameterStk :& - storageStk :& - RNil - -- PAIR - , someStack $ - StkEl (VPair (VUnit, VNat 1)) noAnn (NTPair noAnn noAnn noAnn "something" "parameter" starNotes starNotes) :& - storageStk :& - RNil - -- CAR - , someStack $ StkEl VUnit "something" starNotes :& storageStk :& RNil - -- DROP - , ignoreStack - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ - StkEl (VPair (ops, VNat 2)) noAnn (NTPair noAnn noAnn noAnn noAnn "storage" starNotes starNotes) :& - RNil - ] - - expectedStacks2 :: [Maybe SomeStack] - expectedStacks2 = expectedStacks1 & ix 3 .~ - -- CAR @a - ( someStack $ StkEl VUnit "a" starNotes :& storageStk :& RNil - ) - -unit_CARk_CDRk_interact_with_annotations :: Assertion -unit_CARk_CDRk_interact_with_annotations = do - contract <- importContract (contractsDir "carn_and_cdrn.tz") - stackAnnotationsAssertion - (StkEl (toVal (param, ())) noAnn starNotes :& RNil) - expectedStacks - contract - where - param = (1, 2, ()) :: (Natural, Natural, ()) - paramNotes = [notes|pair nat nat (unit :last)|] - - expectedStacks :: [Maybe SomeStack] - expectedStacks = - [ -- CAR - someStack $ StkEl (toVal param) "parameter" paramNotes :& RNil - -- GET 0 - , someStack $ StkEl (toVal param) noAnn paramNotes :& RNil - -- CDR 0 (macro expanded above) - , someStack $ StkEl (toVal param) noAnn paramNotes :& RNil - -- DUP - , ignoreStack - -- CAR 0 - , someStack $ - StkEl (toVal @Natural 1) noAnn starNotes :& - StkEl (toVal param) noAnn paramNotes :& - RNil - -- DROP - , ignoreStack - -- DUP - , ignoreStack - -- CAR 1 - , someStack $ - StkEl (toVal @Natural 2) noAnn starNotes :& - StkEl (toVal param) noAnn paramNotes :& - RNil - -- DROP - , ignoreStack - -- GET @kek 4 - , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil - -- CDR @kek 2 (macro expanded above) - , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil - -- NIL operation - , ignoreStack - -- PAIR - , someStack $ - StkEl - (VPair (ops, VUnit)) - noAnn - (NTPair noAnn noAnn noAnn noAnn "kek" starNotes (NTUnit "last")) :& - RNil - ] - -unit_CAR_special_annotations :: Assertion -unit_CAR_special_annotations = do - contract <- importContract (contractsDir "car_special_annots.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), ())) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - - replicate 28 ignoreStack - -- When the pair has no annotations - & ix 2 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - & ix 5 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - - -- When the pair has a var annotation - & ix 8 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - & ix 11 .~ (someStack $ StkEl (toVal ()) "pair" starNotes :& RNil) - -- TODO [#534]: should be `pair.car` -----^^^^ - - -- When the pair has field annotations - & ix 14 .~ (someStack $ StkEl (toVal ()) "aa" starNotes :& RNil) - & ix 17 .~ (someStack $ StkEl (toVal ()) "aa" starNotes :& RNil) - - -- When the pair has var + field annotations - & ix 20 .~ (someStack $ StkEl (toVal ()) "aa" starNotes :& RNil) - & ix 23 .~ (someStack $ StkEl (toVal ()) "pair.aa" starNotes :& RNil) - -unit_CDR_special_annotations :: Assertion -unit_CDR_special_annotations = do - contract <- importContract (contractsDir "cdr_special_annots.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), ())) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - - replicate 28 ignoreStack - -- When the pair has no annotations - & ix 2 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - & ix 5 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - - -- When the pair has a var annotation - & ix 8 .~ (someStack $ StkEl (toVal ()) "" starNotes :& RNil) - & ix 11 .~ (someStack $ StkEl (toVal ()) "pair" starNotes :& RNil) - -- TODO [#534]: should be `pair.cdr` -----^^^^ - - -- When the pair has field annotations - & ix 14 .~ (someStack $ StkEl (toVal ()) "bb" starNotes :& RNil) - & ix 17 .~ (someStack $ StkEl (toVal ()) "bb" starNotes :& RNil) - - -- When the pair has var + field annotations - & ix 20 .~ (someStack $ StkEl (toVal ()) "bb" starNotes :& RNil) - & ix 23 .~ (someStack $ StkEl (toVal ()) "pair.bb" starNotes :& RNil) - -unit_UNPAIR_special_annotations :: Assertion -unit_UNPAIR_special_annotations = do - contract <- importContract (contractsDir "unpair_special_annots.tz") - stackAnnotationsAssertion - (starNotesStkEl (toVal ((), ())) :& RNil) - expectedStacks - contract - where - expectedStacks :: [Maybe SomeStack] - expectedStacks = - - replicate 16 ignoreStack - -- When the pair has no annotations - & ix 2 .~ (someStack $ StkEl (toVal ()) "" starNotes :& StkEl (toVal ()) "" starNotes :& RNil) - - -- When the pair has a var annotation - & ix 5 .~ (someStack $ StkEl (toVal ()) "" starNotes :& StkEl (toVal ()) "pair" starNotes :& RNil) - -- TODO [#534]: should be `pair.cdr` -------------------------------------^^^^ - - -- When the pair has field annotations - & ix 8 .~ (someStack $ StkEl (toVal ()) "aa" starNotes :& StkEl (toVal ()) "bb" starNotes :& RNil) - - -- When the pair has var + field annotations - & ix 11 .~ (someStack $ StkEl (toVal ()) "aa" starNotes :& StkEl (toVal ()) "pair.bb" starNotes :& RNil) - -test_special_annotations :: IO TestTree -test_special_annotations = importContract (contractsDir "right_special_anns.tz") <&> - stackAnnotationsTest - "RIGHT uses special field annotations (#439)" - (starNotesStkEl (VPair (VUnit, VUnit)) :& RNil) - expectedStacksRIGHTSpecial - where - expectedStacksRIGHTSpecial :: [Maybe SomeStack] - expectedStacksRIGHTSpecial = - [ -- CAR - someStack $ StkEl (VUnit) "p.y" starNotes :& RNil - -- RIGHT % %@ never - , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" [notes|or never (unit %y)|] :& RNil - -- DROP - -- PUSH unit Unit - -- NUL operation - -- PAIR - , ignoreStack, ignoreStack, ignoreStack, ignoreStack - ] diff --git a/morley-test/Test/Interpreter/Apply.hs b/morley-test/Test/Interpreter/Apply.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Apply.hs +++ /dev/null @@ -1,47 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Tests for the 'APPLY' instruction. -module Test.Interpreter.Apply - ( test_Basic - , test_Partially_applied_lambda_packed - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Typed -import Morley.Michelson.Untyped qualified as U -import Test.Cleveland -import Test.Cleveland.Util (fromHex) - -import Test.Util.Contracts - -test_Basic :: TestTree -test_Basic = testScenarioOnEmulator "" $ scenario do - applyContract <- importUntypedContract $ inContractsDir "apply.tz" - handle <- originateUntypedSimple "apply" (U.ValueInt 0) applyContract - let - lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ] - lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB - transfer TransferData - { tdTo = handle - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = VLam $ RfNormal lam } - getStorage @Integer handle @@== 2 - - -test_Partially_applied_lambda_packed :: TestTree -test_Partially_applied_lambda_packed = testScenarioOnEmulator "" $ scenario do - partApplyContract <- - importUntypedContract $ inContractsDir "partially-applied-lambda-packed.tz" - handle <- originateUntypedSimple "apply" (U.ValueBytes $ U.InternalByteString "") partApplyContract - let expected = unsafe $ fromHex "05020000000f0743035b0005034202000000020316" - transfer TransferData - { tdTo = handle - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = () } - getStorage @ByteString handle @@== expected diff --git a/morley-test/Test/Interpreter/Auction.hs b/morley-test/Test/Interpreter/Auction.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Auction.hs +++ /dev/null @@ -1,146 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Module, containing spec to test auction.tz contract. --- --- This spec is an example of using testing capabilities of morley. -module Test.Interpreter.Auction - ( test_Auction - ) where - -import Hedgehog (forAll, property, withTests) -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) -import Morley.Tezos.Crypto (KeyHash, hashKey) -import Test.Cleveland -import Test.Cleveland.Lorentz.Import (embedContract) -import Test.Cleveland.Util (runGen) - -import Test.Util.Contracts - -type Storage = (Timestamp, (Mutez, KeyHash)) -type Param = KeyHash - --- | Spec to test auction.tz contract. --- --- This test serves as an example on how to test contract with both unit tests --- and Hedgehog. -test_Auction :: [TestTree] -test_Auction = - [ testScenarioOnEmulator "Bid after end of auction triggers failure" $ withInitialNow midTimestamp - $ scenario do - let initState = (aBitBeforeMidTimestamp, (1000, keyHash1)) - handle <- originateSimple @Param @Storage "auction" initState contract - transfer TransferData - { tdTo = handle - , tdAmount = 1200 - , tdEntrypoint = DefEpName - , tdParameter = keyHash2 } - & expectFailedWith () - - , testProperty "Random check (sparse distribution)" $ withTests 200 $ - hhProp genTimestamp genMutez'' - - , testProperty "Random check (dense end of auction)" $ - hhProp denseTime genMutez'' - - , testProperty "Random check (dense amount)" $ - hhProp genTimestamp denseAmount - ] - where - contract = - $$(embedContract @Param @Storage @() (inContractsDir "tezos_examples/attic/auction.tz")) - - hhProp eoaGen amountGen = property do - eoa <- forAll eoaGen - amount <- forAll amountGen - param <- forAll genKeyHash - - testScenarioProps $ withInitialNow midTimestamp $ scenario do - addr <- newFreshAddress auto - pk <- getPublicKey addr - let storage = (eoa, (amount, keyHash)) - keyHash = hashKey pk - handle <- originate OriginateData - { odName = "auction" - , odStorage = storage - , odContract = contract - , odBalance = amount - } - resE <- attempt do - transfer TransferData - { tdTo = handle - , tdAmount = midAmount - , tdEntrypoint = DefEpName - , tdParameter = param } - getStorage handle - validateAuction midTimestamp midAmount addr param storage resE - - aBitBeforeMidTimestamp = midTimestamp `timestampPlusSeconds` -1 - -- ^ 1s before NOW - - denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4 - denseAmount = genMutez' $ Range.constant (midAmount - 4) (midAmount + 4) - midAmount = maxMutez `div` 2 - genMutez'' = genMutez' $ Range.constant 0 maxMutez - maxMutez = maxBound `div` 100 - -keyHash1 :: KeyHash -keyHash1 = runGen 20 300406 genKeyHash - -keyHash2 :: KeyHash -keyHash2 = runGen 20 142917 genKeyHash - --- | This validator checks the result of auction.tz execution. --- --- It checks following properties: --- --- * Current timestamp is before end of auction --- * Amount of new bid is higher than previous one --- --- In case of successful execution: --- --- * End of auction timestamp in updated storage is unchanged --- * Amount in updated storage is equal to @AMOUNT@ of transaction --- * Key hash in updated storage is equal to contract's parameter --- * Script returned exactly one operation, @TransferTokens@, which --- returns money back to the previous bidder -validateAuction - :: MonadCleveland caps m - => Timestamp - -> Mutez - -> Address - -> Param - -> Storage - -> Either SomeException Storage - -> m () -validateAuction ceNow ceAmount addr newKeyHash (endOfAuction, (amount, _)) resE - | ceNow > endOfAuction - = assert (isLeft resE) "Failure didn't trigger on end of auction" - | ceAmount <= amount - = assert (isLeft resE) - "Failure didn't trigger on attempt to bid with amount <= than previous bid" - | Left e <- resE - = failure $ "Unexpected script fail: " <> fromString (displayException e) - - | Right (endOfAuction', _) <- resE - , endOfAuction /= endOfAuction' - = failure "End of auction timestamp of contract changed" - - | Right (_, (amount', _)) <- resE - , amount' /= ceAmount - = failure $ "Storage updated to wrong value: new amount" - <> " is not equal to amount of transaction" - | Right (_, (_, keyHash')) <- resE - , 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 deleted file mode 100644 --- a/morley-test/Test/Interpreter/Balance.hs +++ /dev/null @@ -1,106 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Interpreter.Balance - ( test_balanceIncludesAmount - , test_balanceIncludesAmountComplexCase - ) where - -import Hedgehog (Gen, forAll, property, withTests) -import Hedgehog.Gen qualified as Gen -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Morley.Michelson.Typed -import Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Core -import Test.Cleveland -import Test.Cleveland.Michelson (testTreesWithUntypedContract) - -import Test.Util.Contracts - -data Fixture = - Fixture - { fStartingBalance :: Mutez - , fAmount :: Mutez - } deriving stock (Show) - -genFixture :: Gen Fixture -genFixture = do - fStartingBalance <- Gen.enum 1000 5000 - fAmount <- Gen.enum 0 1000 - return Fixture{..} - -test_balanceIncludesAmount :: IO [TestTree] -test_balanceIncludesAmount = do - testTreesWithUntypedContract - (inContractsDir "check_if_balance_includes_incoming_amount.tz") $ - \checker -> - pure - [ testProperty "BALANCE includes AMOUNT" $ withTests 50 $ property $ do - fixture <- forAll genFixture - testScenarioProps $ scenario $ clevelandBalanceTestScenario - checker fixture - ] - -clevelandBalanceTestScenario :: Monad m => U.Contract -> Fixture -> ClevelandT m () -clevelandBalanceTestScenario checker Fixture{..} = do - let result = unsafeAddMutez fStartingBalance fAmount - - let - uoData = UntypedOriginateData - { uodName = "checkIfBalanceIncludeAmount" - , uodBalance = fStartingBalance - , uodStorage = (untypeValue $ toVal ()) - , uodContract = checker - } - - address <- originateUntyped uoData - let - transferData = TransferData - { tdTo = address - , tdAmount = fAmount - , tdEntrypoint = DefEpName - , tdParameter = result - } - - transfer transferData - getBalance address @@== result - -test_balanceIncludesAmountComplexCase :: IO [TestTree] -test_balanceIncludesAmountComplexCase = do - testTreesWithUntypedContract (inContractsDir "balance_test_case_a.tz") $ \contractA -> - testTreesWithUntypedContract (inContractsDir "balance_test_case_b.tz") $ \contractB -> - pure - [ testScenario "BALANCE returns expected value in nested calls" $ scenario do - let - origDataA = UntypedOriginateData - { uodName = "balance_test_case_a" - , uodBalance = 0 - , uodStorage = (untypeValue $ toVal @[Mutez] []) - , uodContract = contractA - } - let - origDataB = UntypedOriginateData - { uodName = "balance_test_case_b" - , uodBalance = 0 - , uodStorage = (untypeValue $ toVal ()) - , uodContract = contractB - } - addressA <- originateUntyped origDataA - addressB <- originateUntyped origDataB - let - transferData = TransferData - { tdTo = addressA - , tdAmount = 100 - , tdEntrypoint = DefEpName - , tdParameter = addressB - } - - transfer transferData - - -- 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 = [75, 100] - getStorage @[Mutez] addressA @@== expectedStorage - ] diff --git a/morley-test/Test/Interpreter/CallSelf.hs b/morley-test/Test/Interpreter/CallSelf.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/CallSelf.hs +++ /dev/null @@ -1,83 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for the contract that calls self several times. - -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Test.Interpreter.CallSelf - ( test_self_caller - ) where - -import Hedgehog (forAll, property, withTests) -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 Unsafe qualified (fromIntegral) - -import Morley.Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) -import Morley.Michelson.Typed as T -import Morley.Michelson.Untyped qualified as U -import Test.Cleveland -import Test.Cleveland.Michelson (ContractPropValidator, contractProp) -import Test.Cleveland.Michelson.Dummy -import Test.Cleveland.Michelson.Import (embedContract) - -import Test.Util.Contracts - -gasForOneExecution :: Num a => a -gasForOneExecution = 19 - -gasForLastExecution :: Num a => a -gasForLastExecution = 20 - -type Parameter = 'TInt -type Storage = 'TNat - -test_self_caller :: [TestTree] -test_self_caller = - [ testCase ("With parameter 1 single execution consumes " <> - show @_ @Int gasForLastExecution <> " gas") $ - contractProp selfCaller (unitValidator gasForLastExecution) unitContractEnv - (1 :: Integer) (0 :: Natural) - - , testCase ("With parameter 2 single execution consumes " <> - show @_ @Int gasForOneExecution <> " gas") $ - contractProp selfCaller (unitValidator gasForOneExecution) unitContractEnv - (2 :: Integer) (0 :: Natural) - - , testProperty propertyDescription $ - withTests 10 $ property $ do - callCount <- forAll $ Gen.enum minCalls maxCalls - testScenarioProps $ clevelandTransferScenario (T.convertContract selfCaller) callCount - ] - where - -- Environment for unit test - unitContractEnv = dummyContractEnv - -- Validator for unit test - unitValidator :: - RemainingSteps -> ContractPropValidator Storage Assertion - unitValidator gasDiff (_, (isRemainingSteps -> remSteps, _)) = - remSteps @?= ceMaxSteps unitContractEnv - gasDiff - - propertyDescription = - "calls itself n times, sets storage to n OR fails due to gas limit" - - minCalls = 1 - maxCalls = 10 - - selfCaller = $$(embedContract @Parameter @Storage (inContractsDir "call_self_several_times.tz")) - - clevelandTransferScenario :: Monad m => U.Contract -> Integer -> Scenario m - clevelandTransferScenario uSelfContract parameter = scenario do - address <- originateUntypedSimple "self-caller" (U.ValueInt 0) uSelfContract - transfer TransferData - { tdTo = address - , tdAmount = 1 - , tdEntrypoint = DefEpName - , tdParameter = parameter - } - let expectedStorage :: Natural = Unsafe.fromIntegral @Integer @Natural parameter - getStorage @Natural address @@== expectedStorage diff --git a/morley-test/Test/Interpreter/CallSelfAddress.hs b/morley-test/Test/Interpreter/CallSelfAddress.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/CallSelfAddress.hs +++ /dev/null @@ -1,58 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Interpreter.CallSelfAddress - ( test_Call_self_address - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Typed -import Morley.Tezos.Core (zeroMutez) -import Test.Cleveland -import Test.Cleveland.Michelson.Import (embedContract) -import Test.Util.Contracts (inContractsDir) - -type ReceiverParameter = 'TLambda 'TUnit 'TAddress -type ReceiverStorage = 'TUnit - -type SenderParameter = 'TContract ('TLambda 'TUnit 'TAddress) -type SenderStorage = 'TUnit - -test_Call_self_address :: [TestTree] -test_Call_self_address = - -- This tests that the SELF_ADDRESS inside a lambda returns the address - -- of the contract executing the lambda (not the contract defining it). - -- To do so, two contracts called the sender and the receiver are used. - -- The sender (this contract) sends the lambda { DROP; SELF_ADDRESS } - -- to the receiver (see self_address_receiver.tz) who checks that the - -- returned value is the same as its SELF_ADDRESS. - [ testScenario "self_address_sender should call self_address_receiver with no error" $ scenario do - receiverUntyped <- originateUntyped $ UntypedOriginateData - { uodName = "Receiver Contract" - , uodBalance = zeroMutez - , uodStorage = untypeValue $ toVal () - , uodContract = convertContract receiverContract - } - senderUntyped <- originateUntyped $ UntypedOriginateData - { uodName = "Receiver Contract" - , uodBalance = zeroMutez - , uodStorage = untypeValue $ toVal () - , uodContract = convertContract senderContract - } - - let params :: Value SenderParameter - = VContract receiverUntyped (SomeEpc unsafeEpcCallRoot) - - transfer TransferData - { tdTo = senderUntyped - , tdAmount = zeroMutez - , tdEntrypoint = DefEpName - , tdParameter = params - } - ] - where - receiverContract = - $$(embedContract @ReceiverParameter @ReceiverStorage (inContractsDir "self_address_receiver.tz")) - senderContract = - $$(embedContract @SenderParameter @SenderStorage (inContractsDir "self_address_sender.tz")) diff --git a/morley-test/Test/Interpreter/ComparableSet.hs b/morley-test/Test/Interpreter/ComparableSet.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/ComparableSet.hs +++ /dev/null @@ -1,49 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Module, containing spec to test compare.tz contract. -module Test.Interpreter.ComparableSet - ( test_comparable_set - ) where - -import Data.Set as Set (fromList, toList) -import Hedgehog (forAll, property, withTests) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Morley.Michelson.Interpret (ContractReturn) -import Morley.Michelson.Typed (ToT) -import Test.Cleveland -import Test.Cleveland.Michelson.Import (embedContract) -import Test.Cleveland.Util (genTuple2) - -import Test.Util.Contracts - -type Param = Set (Integer, Integer) -type HContractStorage = Maybe (Integer, Integer) -type ContractResult = ContractReturn (ToT HContractStorage) - --- | Spec to test comparable_set.tz contract. -test_comparable_set :: [TestTree] -test_comparable_set = - [ testScenarioOnEmulator "success test" $ myScenario (fromList [ (10, 11) , (10, 12)]) - , testProperty "Random check" $ - withTests 200 $ property $ do - let genInteger = Gen.integral (Range.linearFrom 0 -1000 1000) - inputParam <- forAll $ Gen.set (Range.linear 0 100) (genTuple2 genInteger genInteger) - testScenarioProps $ myScenario inputParam - ] - where - contract = $$(embedContract @(ToT Param) @(ToT HContractStorage) (inContractsDir "comparable_set.tz")) - - myScenario :: Monad m => Param -> Scenario m - myScenario inp = scenario do - handle <- originateTypedSimple @Param @HContractStorage @() "compare" Nothing contract - call handle CallDefault inp - getStorage handle @@== mkExpected inp - pure () - - mkExpected :: Param -> HContractStorage - mkExpected = fmap maximum . nonEmpty . Set.toList diff --git a/morley-test/Test/Interpreter/Compare.hs b/morley-test/Test/Interpreter/Compare.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Compare.hs +++ /dev/null @@ -1,86 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Module, containing spec to test compare.tz contract. -module Test.Interpreter.Compare - ( test_compare - , test_Equality_vs_compare - ) where - -import Hedgehog (MonadTest, discard, forAll, property, withDiscards, withTests, (===)) -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Michelson.Typed -import Hedgehog.Gen.Michelson.Untyped qualified as U -import Hedgehog.Gen.Tezos.Core (genMutez) -import Morley.Michelson.Interpret (ContractReturn) -import Morley.Michelson.Typed (ToT, fromVal) -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) - -import Test.Util.Contracts - -type Param = (Mutez, Mutez) -type ContractResult = ContractReturn (ToT [Bool]) - --- | Spec to test compare.tz contract. -test_compare :: [TestTree] -test_compare = - [ testScenarioOnEmulator "success test" $ myScenario (10, 11) - , testProperty "Random check" $ - withTests 200 $ property $ do - inputParam <- forAll $ genTuple2 genMutez genMutez - testScenarioProps $ myScenario inputParam - ] - where - contract = $$(embedContract @Param @[Bool] @() (inContractsDir "tezos_examples/macros/compare.tz")) - - myScenario :: Monad m => Param -> Scenario m - myScenario inp = scenario do - handle <- originateSimple "compare" [] contract - call handle CallDefault inp - getStorage handle @@== mkExpected inp - pure () - - initStorage :: [Bool] - initStorage = [] - - mkExpected :: Param -> [Bool] - mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b] - - validate - :: MonadTest m - => [Bool] - -> ContractResult - -> m () - validate e (Right ([], fromVal -> l), _) = l === e - validate _ (Left _, _) = failedTest "Unexpected fail of script." - validate _ _ = failedTest "Invalid result got." - -{-# ANN module ("HLint: ignore Redundant compare" :: Text) #-} - --- | This test is necessary because there exist two notions of comparable --- values - in Michelson world (works only for specific types) and in --- Haskell world (works for all values). --- And at the moment of writing we define 'Ord' instance for 'Value' as in --- Michelson, while 'Eq' instance is produced by Haskell means automatically. --- --- In various places we rely on the fact that instance produced by Haskell --- matches the Michelson definitions, so we have to ensure that on comparable --- types (in terms of Michelson) our @Eq@ and @Ord@ instances match. -test_Equality_vs_compare :: TestTree -test_Equality_vs_compare = - 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, T.getWTP' st) of - (T.CanBeCompared, T.OpAbsent, Right T.Dict) -> do - value1 <- forAll $ genValue' st - value2 <- forAll $ genValue' st - forM_ ((,) <$> [value1, value2] <*> [value1, value2]) $ \(v1, v2) -> - (compare v1 v2 == EQ) === (v1 == v2) - _ -> discard diff --git a/morley-test/Test/Interpreter/ComparePairs.hs b/morley-test/Test/Interpreter/ComparePairs.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/ComparePairs.hs +++ /dev/null @@ -1,46 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Module, containing spec to test compare.tz contract. -module Test.Interpreter.ComparePairs - ( test_compare_pairs - ) where - -import Hedgehog (forAll, property, withTests) -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Tezos.Core (genMutez) -import Morley.Tezos.Core (Mutez) -import Test.Cleveland -import Test.Cleveland.Lorentz.Import (embedContract) -import Test.Cleveland.Util (genTuple2) - -import Test.Util.Contracts - -type Param = ((Mutez, Mutez), (Mutez, Mutez)) - --- | Spec to test compare.tz contract. -test_compare_pairs :: [TestTree] -test_compare_pairs = - [ testScenarioOnEmulator "success test" $ myScenario - ( (10, 11) - , (10, 12) - ) - , testProperty "Random check" $ - withTests 200 $ property $ do - inputParam <- forAll $ genTuple2 (genTuple2 genMutez genMutez) (genTuple2 genMutez genMutez) - testScenarioProps $ myScenario inputParam - ] - where - myScenario :: Monad m => Param -> Scenario m - myScenario inp = scenario do - handle <- originateSimple "compare_pairs" [] contract - call handle CallDefault inp - getStorage handle @@== mkExpected inp - pure () - - contract = $$(embedContract @Param @[Bool] @() (inContractsDir "compare_pairs.tz")) - - mkExpected :: Param -> [Bool] - mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b] diff --git a/morley-test/Test/Interpreter/Conditionals.hs b/morley-test/Test/Interpreter/Conditionals.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Conditionals.hs +++ /dev/null @@ -1,60 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Module, containing spec to test conditionals.tz contract. -module Test.Interpreter.Conditionals - ( test_conditionals - ) where - -import Hedgehog (forAll, property) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import Test.Tasty (TestTree) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Michelson (genMText) -import Morley.Michelson.Text -import Morley.Michelson.Typed (ToT, convertContract) -import Morley.Michelson.Untyped -import Test.Cleveland -import Test.Cleveland.Michelson.Import (embedContract) - -import Test.Util.Contracts - -type Param = Either MText (Maybe Integer) - --- | Spec to test conditionals.tz contract. -test_conditionals :: [TestTree] -test_conditionals = - [ testScenarioOnEmulator "single test" $ scenario do - handle <- originateUntypedSimple "conditionals" (ValueString "storage") $ convertContract contract - transfer $ TransferData - { tdTo = handle - , tdEntrypoint = DefEpName - , tdParameter = Left "abc" :: Param - , tdAmount = 0 - } - getStorage @MText handle @@== "abc" - , testProperty "randomized check" $ property do - inputParam :: Param <- forAll $ Gen.either - genMText - (Gen.maybe (Gen.integral (Range.linearFrom 0 -1000 1000))) - testScenarioProps $ scenario do - handle <- originateUntypedSimple "conditionals" (ValueString "storage") $ convertContract contract - transfer TransferData - { tdTo = handle - , tdEntrypoint = DefEpName - , tdParameter = inputParam - , tdAmount = 0 - } - & case inputParam of - Left str -> (>> (getStorage @MText handle @@== str)) - Right Nothing -> expectFailedWith () - Right (Just a) - | a < 0 -> expectFailedWith () - | otherwise -> (>> (getStorage @MText handle @@== "")) - ] - where - contract = $$(embedContract @(ToT Param) @(ToT MText) (inContractsDir "tezos_examples/attic/conditionals.tz")) diff --git a/morley-test/Test/Interpreter/ContractOp.hs b/morley-test/Test/Interpreter/ContractOp.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/ContractOp.hs +++ /dev/null @@ -1,73 +0,0 @@ --- 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 -import Morley.Tezos.Address -import Test.Cleveland -import Test.Cleveland.Lorentz.Import (embedContract) - -import Test.Util.Contracts - --- | Spec to test @contract_op.tz@ contract. --- --- Test results are confirmed by the reference implementation. -test_contract_op :: [TestTree] -test_contract_op = - [ testScenarioOnEmulator "contract not found" $ scenario do - contract_op <- originateSimple "contract_op" False contract - call contract_op CallDefault [ta|KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9|] - getStorage contract_op @@== False - ] <> - map (\(res, notes) -> testScenarioOnEmulator (msg res notes) $ scenario do - contract_op <- originateSimple "contract_op" False contract - test <- originateUntypedSimple "test_contract" ValueUnit $ - minimalContract notes - transfer TransferData - { tdTo = contract_op - , tdParameter = test - , tdAmount = 0 - , tdEntrypoint = DefEpName - } - getStorage contract_op @@== res - ) - [ (True, intQ "root" ) - , (True, int "root" ) - , (False, intQ noAnn ) - , (False, int noAnn ) - , (False, intP noAnn ) - , (False, string noAnn ) - , (False, intP "root" ) - , (False, intQ "another_root" ) - ] - where - contract = $$(embedContract @Address @Bool @() (inContractsDir "contract_op.tz")) - - minimalContract :: ParameterType -> Contract - minimalContract contractParameter = Contract - { contractStorage = Ty TUnit noAnn - , contractCode = PrimEx <$> - [ CDR noAnn noAnn - , NIL noAnn noAnn (Ty TOperation noAnn) - , PAIR noAnn noAnn noAnn noAnn - ] - , entriesOrder = PSC - , contractViews = [] - , .. - } - - msg isGood paramType = - "parameter in environment is '" <> pretty paramType <> "', " <> - bool "" "but " isGood <> "contract expects '%root int :q'" - - intQ = ParameterType $ Ty TInt "q" - int = ParameterType $ Ty TInt noAnn - intP = ParameterType $ Ty TInt "p" - string = ParameterType $ Ty TString noAnn diff --git a/morley-test/Test/Interpreter/CreateAndReverseOps.hs b/morley-test/Test/Interpreter/CreateAndReverseOps.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/CreateAndReverseOps.hs +++ /dev/null @@ -1,36 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'create_2_n_reverse_ops.tz' contract. - --- Here we check that by storing 'GlobalCounter' in 'OriginationOpertion' --- contract addresses aren't confused with each other even if we reverse the --- list of operations manually in the contract. - -module Test.Interpreter.CreateAndReverseOps - ( test_createAndReverseOps - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Text (MText) -import Morley.Tezos.Address -import Test.Cleveland -import Test.Cleveland.Instances () -import Test.Util.Contracts - -test_createAndReverseOps :: IO TestTree -test_createAndReverseOps = - pure $ testScenario "Resuling addresses match each other" $ scenario do - contract <- importContract @() @(Address, Address) @() - (contractsDir "create_2_n_reverse_ops.tz") - createAndReverseOps <- originateSimple "createAndReverseOps" (someAddr, someAddr) contract - call createAndReverseOps CallDefault () - (addrWithUnitStorage, addrWithStringStorage) <- - getStorage @(Address, Address) createAndReverseOps - () <- getStorage @() addrWithUnitStorage - stString <- getStorage @MText addrWithStringStorage - stString @== "kek" - -someAddr :: Address -someAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/CreateAndTransfer.hs b/morley-test/Test/Interpreter/CreateAndTransfer.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/CreateAndTransfer.hs +++ /dev/null @@ -1,28 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'create_n_transfer.tz' contract. See [#643] -module Test.Interpreter.CreateAndTransfer - ( test_createAndTranfser - ) where - -import Test.Tasty (TestTree) - -import Morley.Tezos.Address -import Test.Cleveland -import Test.Cleveland.Instances () -import Test.Util.Contracts - -test_createAndTranfser :: IO TestTree -test_createAndTranfser = - pure $ testScenario "'create_n_transfer.tz' performs transfer after origination" $ scenario do - contract <- importContract @() @() @() (contractsDir "create_n_transfer.tz") - createAndTransfer <- originateSimple "createAndTransfer" () contract - oldBalance <- getBalance constAddr - transferMoney createAndTransfer 10 - newBalance <- getBalance constAddr - newBalance - oldBalance @== 1 - --- Address hardcoded in 'create_n_transfer.tz'. -constAddr :: Address -constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/EnvironmentSpec.hs b/morley-test/Test/Interpreter/EnvironmentSpec.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/EnvironmentSpec.hs +++ /dev/null @@ -1,97 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for the 'environment.tz' contract - -module Test.Interpreter.EnvironmentSpec - ( test_environment - ) where - -import Hedgehog (Gen, forAll, property, withTests) -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 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) - -import Test.Util.Contracts - -test_environment :: [TestTree] -test_environment = - [ testImpl contract - , testScenario "Default balance" $ scenario do - addr <- newFreshAddress "random address testDefaultBalance" - transferMoney addr 1 - getBalance addr @@== 1 - ] - where - contract = $$(embedContract @'TAddress @'TUnit (inContractsDir "environment.tz")) - -data Fixture = Fixture - { fPassOriginatedAddress :: Bool - , fBalance :: Mutez - , fAmount :: Mutez - } deriving stock (Show) - -genFixture :: Gen Fixture -genFixture = do - fPassOriginatedAddress <- Gen.bool - fBalance <- Gen.enum 1 1234 - fAmount <- Gen.enum 1 42 - return Fixture {..} - -testImpl - :: T.Contract 'TAddress 'TUnit - -> TestTree -testImpl environment = do - -- The conditions under which this contract fails are described in a comment - -- at the beginning of the contract. - testProperty "contract fails under certain conditions" $ - withTests 50 $ property $ do - fixture <- forAll genFixture - testScenarioProps $ scenario do - -- Let's originate the 'environment.tz' contract - let - uoData = UntypedOriginateData - { uodName = "environment" - , uodBalance = fBalance fixture - , uodStorage = U.ValueUnit - , uodContract = (T.convertContract environment) - } - - environmentAddress <- originateUntyped uoData - - -- And transfer tokens to it - let - param - | fPassOriginatedAddress fixture = environmentAddress - | otherwise = genesisAddress - transferData = TransferData - { tdTo = environmentAddress - , tdAmount = fAmount fixture - , tdEntrypoint = DefEpName - , tdParameter = param - } - - -- Execute operations and check that interpreter fails when one of - -- failure conditions is met or updates environment's storage - -- approriately - let - balanceAfterTransfer = fBalance fixture `unsafeAddMutez` fAmount fixture - if - | balanceAfterTransfer > 1000 -> - expectFailedWith balanceAfterTransfer $ - transfer transferData - | fPassOriginatedAddress fixture -> - expectFailedWith environmentAddress $ - transfer transferData - | 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 deleted file mode 100644 --- a/morley-test/Test/Interpreter/Print.hs +++ /dev/null @@ -1,99 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for the @PRINT@ extended command - -module Test.Interpreter.Print - ( test_print_simple - , test_print_operations - ) where - -import Data.Default (Default(def)) -import Fmt ((+|), (|+)) -import Test.Tasty (TestTree) - -import Morley.Michelson.Interpret (MorleyLogs(..)) -import Morley.Michelson.Text (MText) -import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Typed.Instr -import Morley.Tezos.Address (Address) -import Test.Cleveland - -test_print_simple :: [TestTree] -test_print_simple = - [ testScenarioOnEmulator "PRINT prints naturals" $ scenarioEmulated do - printer <- originateTypedSimple @Natural @_ @() "printer" () printerContract - logsInfo <- getMorleyLogs_ $ - call printer CallDefault (123 :: Natural) - collectLogs logsInfo @== MorleyLogs ["123"] - , testScenarioOnEmulator "PRINT prints strings" $ scenarioEmulated do - printer <- originateTypedSimple @MText @_ @() "printer" () printerContract - logsInfo <- getMorleyLogs_ $ - call printer CallDefault "hello" - collectLogs logsInfo @== MorleyLogs ["\"hello\""] - , testScenarioOnEmulator "PRINT prints right combs" $ scenarioEmulated do - printer <- originateTypedSimple @(Integer, (Integer, Integer)) @_ @() "printer" () printerContract - logsInfo <- getMorleyLogs_ $ - call printer CallDefault (1, (2, 3)) - collectLogs logsInfo @== MorleyLogs ["{ 1; 2; 3 }"] - , testScenarioOnEmulator "PRINT prints sequences" $ scenarioEmulated do - printer <- originateTypedSimple @[Integer] @_ @() "printer" () printerContract - logsInfo <- getMorleyLogs_ $ - call printer CallDefault [1..5] - collectLogs logsInfo @== MorleyLogs ["{ 1; 2; 3; 4; 5 }"] - ] - -test_print_operations :: TestTree -test_print_operations = - testScenarioOnEmulator "PRINT prints operations" $ scenarioEmulated do - addr <- newFreshAddress auto - printer <- originateTypedSimple @Address @_ @() "printerOps" () operationPrinter - logsInfo <- getMorleyLogs_ $ - call printer CallDefault addr - collectLogs logsInfo @== - MorleyLogs ["{ Transfer 123 μꜩ tokens to Contract " +| addr |+ " call Call : × }"] - -operationPrinter :: T.Contract 'T.TAddress 'T.TUnit -operationPrinter = T.Contract{..} - where - cParamNotes = T.starParamNotes - cStoreNotes = T.starNotes - - cEntriesOrder = def - - stackRef = PrintComment . one . Right $ mkStackRef @0 - - cViews = def - cCode :: Instr '[ 'T.TPair 'T.TAddress 'T.TUnit ] '[ 'T.TPair ('T.TList 'T.TOperation) 'T.TUnit ] - cCode = - UNPAIR `Seq` - CONTRACT T.starNotes T.DefEpName `Seq` - IF_NONE (PUSH (T.VString "No contract") `Seq` FAILWITH) ( - PUSH (T.VMutez 123) `Seq` - PUSH T.VUnit `Seq` - TRANSFER_TOKENS `Seq` - DIP NIL `Seq` - CONS `Seq` - Ext (PRINT stackRef) `Seq` - DROP `Seq` - NIL `Seq` - PAIR - ) - -printerContract :: (T.ContainsNestedBigMaps p ~ 'False, T.ConstantScope p) => T.Contract p (T.ToT ()) -printerContract = T.Contract{..} - where - cParamNotes = T.starParamNotes - cStoreNotes = T.starNotes - - cEntriesOrder = def - - stackRef = PrintComment . one . Right $ mkStackRef @0 - - cViews = def - cCode = - UNPAIR `Seq` - Ext (PRINT stackRef) `Seq` - DROP `Seq` - NIL `Seq` - PAIR diff --git a/morley-test/Test/Interpreter/Reference.hs b/morley-test/Test/Interpreter/Reference.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Reference.hs +++ /dev/null @@ -1,308 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Interpreter.Reference - ( test_InterpreterWithReferenceImplementation - , test_Regression688 - ) where - -import Data.Default (def) -import Data.Singletons (Sing) -import Data.Typeable ((:~:)(Refl)) -import Fmt (pretty) -import Hedgehog (MonadTest, PropertyT, annotate, evalIO, forAll, property, withTests, (===)) -import System.IO.Silently (silence) -import Test.Tasty (TestTree, testGroup) -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.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(..)) -import Morley.Michelson.Typed - (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 Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Address -import Morley.Tezos.Core (Timestamp(..), dummyChainId, getCurrentTime, zeroMutez) -import Morley.Tezos.Crypto -import Morley.Util.Named -import Morley.Util.Sing (eqI) -import Test.Cleveland (NetworkEnv(neMorleyClientEnv)) -import Test.Cleveland.Michelson.Import -import Test.Cleveland.Tasty (whenNetworkEnabled) -import Test.Cleveland.Util (failedTest) -import Test.Util.Contracts (getWellTypedMichelsonContracts) - -test_InterpreterWithReferenceImplementation :: IO TestTree -test_InterpreterWithReferenceImplementation = do - files <- filter (`notElem` excludedContracts) <$> getWellTypedMichelsonContracts - - filesAndContracts :: [(FilePath, SomeContract)] <- - forM files $ \file -> do - someContract <- importSomeContract file - pure (file, someContract) - - pure $ - whenNetworkEnabled $ \withEnv -> - testGroup "compare interpreter with reference implementation" $ - withFrozenCallStack $ testContract withEnv <$> filesAndContracts - where - -- These constracts are currently excluded from the tests since - -- our or reference implementations doesn't act in an expected way. - -- - -- Ideally, we should remove the usage of this list one day :coolstory: - excludedContracts :: [FilePath] - excludedContracts = - [ "../../contracts/tezos_examples/mini_scenarios/replay.tz" - , "../../contracts/replay_origination.tz" - , "../../contracts/replay_transfer.tz" - -- ↑ See [#320] and https://gitlab.com/tezos/tezos/-/issues/897 - , "../../contracts/call_self_several_times.tz" - , "../../contracts/tezos_examples/attic/cps_fact.tz" - -- ↑ Due to that fact that 'run_code' doesn't perform internal operations in contrary to morley interpreter - , "../../contracts/tezos_examples/mini_scenarios/multiple_entrypoints_counter.tz" - , "../../contracts/tezos_examples/mini_scenarios/multiple_en2.tz" - -- TODO [#699]: find out why these still fail - -- ↑ 'SELF' and 'SENDER' instruction return same addresses in 'run_code' - , "../../contracts/tezos_examples/mini_scenarios/lockup.tz" - , "../../contracts/tezos_examples/attic/forward.tz" - -- ↑ Reference 'run_code' implementation does something weird to allow transfers with arbitrary - -- amounts even when BALANCE + AMOUNT < required amount of money that needs to be transfered. - -- This probably will be resolved in https://gitlab.com/tezos/tezos/-/issues/897, when 'run_code' - -- will actually try to apply operation instead of running it inside weird environment. - -- Or in [#406] if the issue turns to be on our side. - , "../../contracts/voting_powers.tz" - , "../../contracts/tezos_examples/opcodes/voting_power.tz" - -- ↑ We cannot predict the total voting power in a real chain. - -- There is still a similar @voting_power.tz@ that touches only - -- @VOTING_POWER@ instruction. - , "../../contracts/tezos_examples/opcodes/level.tz" - -- ↑ 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 -test_Regression688 = do - let file = "../../contracts/tezos_examples/mini_scenarios/xcat_dapp.tz" - parameter = VOr @_ @('TOr 'TBytes 'TBytes) $ Left $ - VPair - (VAddress $ EpAddress - { eaAddress = KeyAddress $ KeyHash - { khTag = KeyHashEd25519 - , khBytes = "UK\224\155\204\188\151\163%\183I\194*H\252P\246\&4\192\205" - } - , eaEntrypoint = U.DefEpName} - , VPair (VBytes "", VTimestamp $ Timestamp 1225497600) - ) - storage = VPair ( - VBigMap @'TBytes @('TPair ('TPair 'TAddress 'TAddress) ('TPair 'TMutez 'TTimestamp)) - Nothing mempty,VUnit) - - contract <- importContract file - - pure $ - whenNetworkEnabled $ \withEnv -> - testProperty "#688 regression test" $ withTests 1 $ property $ - withFrozenCallStack $ compareWithReference withEnv file contract parameter storage - -testContract - :: HasCallStack - => (forall a. (NetworkEnv -> IO a) -> IO a) - -> (FilePath, SomeContract) -> TestTree -testContract withEnv (file, someContract) = - case someContract of - SomeContract (contract@Contract {} :: Contract cp st) -> - -- We run each contract 4 times to check that it behaves the same way on different - -- inputs. - testProperty ("compare result with morley interpreter for " <> file) $ - withTests 4 $ property $ do - parameter <- forAll $ genValue @cp - storage <- forAll $ genValue @st - - compareWithReference withEnv file contract parameter storage - -compareWithReference - :: forall cp st. (ParameterScope cp, StorageScope st) - => (forall a. (NetworkEnv -> IO a) -> IO a) - -> FilePath -> Contract cp st -> Value cp -> Value st -> PropertyT IO () -compareWithReference withEnv file contract parameter storage = do - (resReference, resMorley) <- - evalIO $ - withEnv \env -> do - resReference <- try @_ @RunCodeErrors $ - runMorleyClientM (neMorleyClientEnv env) $ - Reference.runContract @cp @st RunContractParameters - { rcpContract = contract - , rcpParameter = NotRPC parameter - , rcpStorage = NotRPC storage - , rcpBalance = 4000000000000 - , rcpAmount = zeroMutez - , rcpSender = Just genesisAddress - , rcpSource = Just genesisAddress - } - 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 50000 else minBound - resMorley <- try @_ @ExecutorError $ silence $ - Morley.runContract (Just currentTimestamp) (Just 0) 100500 4000000000000 "" - tcOptions (untypeValue storage) (convertContract contract) - (TxData genesisAddress (TxUntypedParam $ untypeValue parameter) U.DefEpName amount) - (#verbose :! False) - (#dryRun :! True) - - pure (resReference, resMorley) - - compareResults resReference resMorley parameter storage - -tcOptions :: TypeCheckOptions -tcOptions = def - { -- Since we test against @tezos-client run@ - tcStrict = False - } - -compareResults - :: forall cp st m. - (HasCallStack, StorageScope st, MonadTest m) - => Either RunCodeErrors (AsRPC (Value st)) - -> Either ExecutorError SomeStorage -> Value cp -> Value st -> m () -compareResults (Left rpcErr) (Left interpreterErr) _ _ = compareErrors rpcErr interpreterErr -compareResults (Left err) (Right _) parameter storage = do - failedTest . fromString $ - "Morley interpreter unexpectedly didn't fail.\n Passed parameter: " <> pretty parameter <> - ".\n Passed storage: " <> pretty storage <> ".\n Reference implementation failed with: " <> - pretty err -compareResults (Right _) (Left err) parameter storage = do - failedTest . fromString $ - "Morley interpreter unexpectedly failed.\n " <> "Passed parameter: " <> pretty parameter <> - ".\n Passed storage: " <> pretty storage <> ".\n Morley interpreter failed with: " <> - displayException err -compareResults (Right st1) (Right (SomeStorage (st2 :: Value st2))) parameter storage = - withDict (rpcStorageScopeEvi @st) $ do - case eqI @st @st2 of - Nothing -> - failedTest . fromString $ "Result storages have different types.\n" <> - "Reference implementation returned storage: " <> pretty st1 <> ".\n" <> - "Morley returned storage: " <> pretty st2 - Just Refl -> do - annotate $ - ("Both contracts succeeded, but new storages are different.\n Passed parameter: " <> - pretty parameter <> ".\n Passed storage: " <> pretty storage <> ".\n" <> - "Reference implementation returned storage: " <> pretty st1 <> ".\n" <> - "Morley returned storage: " <> pretty st2 - ) - compareValues st1 st2 - --- | Compare values with weaken equality requirements, e.g. we don't --- check that @VAddress@, @VBytes@, @VChainId@ and @VTimestamp@ have same constructor arguments, --- since they can be different even when both interpreters were successfully run. --- --- 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 (TAsRPC st) -> Value st -> m () -compareValues storageReference storageMorley = - preprocessValue storageReference === preprocessValue (valueAsRPC storageMorley) - where - preprocessValue :: Value (TAsRPC st) -> Value (TAsRPC st) - preprocessValue = dfsMapValue placeStubs . scrubBigMapIDs (sing @st) - - placeStubs :: Value t -> Value t - placeStubs = \case - VAddress _ -> VAddress $ EpAddress genesisAddress U.DefEpName - VBytes _ -> VBytes "kek" - VChainId _ -> VChainId dummyChainId - VTimestamp _ -> VTimestamp $ Timestamp 100 - v -> v - - -- | Scrub all big_map IDs from a storage value. - -- - -- 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 (TAsRPC t) -> Value (TAsRPC t) - scrubBigMapIDs storageSing storage = - case (storageSing, storage) of - (STBigMap{}, VNat _) -> VNat 0 - (STOption vSing, VOption v) -> VOption $ scrubBigMapIDs vSing <$> v - (STList vSing, VList v) -> VList $ scrubBigMapIDs vSing <$> v - (STPair lSing rSing, VPair v) -> VPair $ bimap (scrubBigMapIDs lSing) (scrubBigMapIDs rSing) v - (STOr lSing rSing, VOr v) -> VOr $ bimap (scrubBigMapIDs lSing) (scrubBigMapIDs rSing) v - (STMap _ vSing, VMap v) -> VMap $ scrubBigMapIDs vSing <$> v - _ -> storage - -assertRpcErrs :: (HasCallStack, MonadTest m) => [RunError] -> (RunError -> Bool) -> String -> m () -assertRpcErrs errs predicate msg = - if any predicate errs then pass else do failedTest $ fromString msg - --- Note that error comparison can be extended when the new contracts will be added. -compareErrors :: (HasCallStack, MonadTest m) => RunCodeErrors -> ExecutorError -> m () -compareErrors rpcErr@(RunCodeErrors errs) interpreterErr = case interpreterErr of - EEInterpreterFailed _ (InterpretError (mfwsFailed -> runtimeErr, _)) -> case runtimeErr of - MichelsonFailedWith _ -> - assertRpcErrs errs - (\case - ScriptRejected {} -> True - _ -> False - ) $ "Morley interpreter failed with FAILWITH, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - MichelsonArithError arithErr -> case arithErr of - ShiftArithError {}-> - assertRpcErrs errs - (\case - ScriptOverflow -> True - _ -> False - ) $ "Morley interpreter failed with shift overflow, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - MutezArithError AddOverflow _ _ -> - assertRpcErrs errs - (\case - MutezAdditionOverflow {} -> True - _ -> False - ) $ "Morley interpreter failed with mutez addition overflow, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - MutezArithError MulOverflow _ _ -> - assertRpcErrs errs - (\case - MutezMultiplicationOverflow {} -> True - ScriptOverflow -> True - _ -> False - ) $ "Morley interpreter failed with mutez multiplication overflow, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - MichelsonGasExhaustion -> - assertRpcErrs errs - (\case - GasExhaustedOperation -> True - _ -> False - ) $ "Morley interpreter failed due to gas exhaustion, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - _ -> do - failedTest . fromString $ "Unexpected morley runtime failure:\n" <> pretty runtimeErr <> - "\nReference interpreter failed with:\n" <> displayException rpcErr - EEIllTypedParameter _ _ -> - assertRpcErrs errs - (\case - InconsistentTypes {} -> True - BadContractParameter {} -> True - _ -> False - ) $ "Morley interpreter failed during parmeter typechecking, \ - \however reference interpreter failed with:\n" <> displayException rpcErr - _ -> do - failedTest . fromString $ "Unexpected morley interpreter failure:\n" <> displayException interpreterErr <> - "\nReference interpreter failed with:\n" <> displayException rpcErr diff --git a/morley-test/Test/Interpreter/SetDelegate.hs b/morley-test/Test/Interpreter/SetDelegate.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/SetDelegate.hs +++ /dev/null @@ -1,31 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'create_n_transfer.tz' contract. See [#643] -module Test.Interpreter.SetDelegate - ( test_setDelegate - ) where - -import Test.Tasty (TestTree) - -import Morley.Michelson.Typed -import Morley.Tezos.Crypto -import Test.Cleveland - -contract :: Contract ('TOption 'TKeyHash) 'TUnit -contract = defaultContract $ - CAR `Seq` SET_DELEGATE `Seq` DIP NIL `Seq` CONS `Seq` DIP UNIT `Seq` PAIR - -test_setDelegate :: IO TestTree -test_setDelegate = - pure $ testScenario "setDelegate works" $ scenario do - handle <- originateTypedSimple @(Maybe KeyHash) @_ @() "set_delegate" () contract - getDelegate handle @@== Nothing - addr <- newAddress "delegate" - registerDelegate addr - pk <- getPublicKey addr - let kh = hashKey pk - call handle CallDefault (Just kh) - getDelegate handle @@== Just kh - call handle CallDefault Nothing - getDelegate handle @@== Nothing diff --git a/morley-test/Test/Interpreter/StackRef.hs b/morley-test/Test/Interpreter/StackRef.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/StackRef.hs +++ /dev/null @@ -1,36 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Interpreter tests involving 'StackRef'. - -module Test.Interpreter.StackRef - ( test_mkStackRef - ) where - -import Data.Default (def) -import Test.Tasty (TestTree) - -import Morley.Michelson.Typed -import Test.Cleveland - -test_mkStackRef :: TestTree -test_mkStackRef = - testScenarioOnEmulator "does not segfault" $ scenario do - handle <- originateTypedSimple @() @() @() "test_contract" () contract - call handle CallDefault () - where - stackRef = PrintComment . one . Right $ mkStackRef @1 - - contract :: Contract 'TUnit 'TUnit - contract = Contract - { cCode = contractCode - , cStoreNotes = starNotes - , cParamNotes = starParamNotes - , cEntriesOrder = def - , cViews = def - } - - contractCode :: ContractCode 'TUnit 'TUnit - contractCode = - CAR `Seq` DUP `Seq` Ext (PRINT stackRef) `Seq` - DROP `Seq` NIL `Seq` PAIR diff --git a/morley-test/Test/Interpreter/StringCaller.hs b/morley-test/Test/Interpreter/StringCaller.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/StringCaller.hs +++ /dev/null @@ -1,100 +0,0 @@ --- 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 --- their behavior. - -module Test.Interpreter.StringCaller - ( test_stringCaller - ) where - -import Hedgehog (forAll, property, withTests) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Michelson (genMText) -import Morley.Michelson.Text (MText) -import Morley.Tezos.Address (Address, ta) -import Test.Cleveland -import Test.Cleveland.Lorentz.Import (embedContract) - -import Test.Util.Contracts - -test_stringCaller :: TestTree -test_stringCaller = - -- failOrStoreAndTransfer's pre-conditions: - -- balance is >= 1300 - testGroup "calls failOrStoreAndTransfer, updates storage & balance, checks pre-conditions" - [ testScenario "when parameter is a constant" $ myScenario constStr - - -- The test is trivial, so it's kinda useless to run it many times - , testProperty "when parameter is an arbitrary value" $ - withTests 2 $ property do - mtext <- forAll genMText - testScenarioProps $ myScenario mtext - ] - where - constStr = "caller" - -myScenario :: Monad m => MText -> Scenario m -myScenario str = scenario do - let - initFailOrStoreBalance = 900 - initStringCallerBalance = 500 - - failOrStoreAddress <- originate OriginateData - { odName = "failOrStoreAndTransfer" - , odBalance = initFailOrStoreBalance - , odStorage = "hello" - , odContract = failOrStoreAndTransfer - } - - stringCallerAddress <- originate OriginateData - { odName = "stringCaller" - , odBalance = initStringCallerBalance - , odStorage = chAddress failOrStoreAddress - , odContract = stringCaller - } - - initialConstAddrBalance <- getBalance constAddr - - -- Transfer 100 tokens to stringCaller, it should transfer 300 tokens - -- to failOrStoreAndTransfer - let - transferData = TransferData - { tdTo = stringCallerAddress - , tdAmount = 100 - , tdEntrypoint = DefEpName - , tdParameter = str - } - - transferToStringCaller = transfer transferData - transferToStringCaller - - -- Execute operations and check balances and storage of 'failOrStore' - do - let - -- `string_caller.tz` transfers 300 mutez. - -- 'fail_or_store_and_transfer.tz' transfers 5 tokens. - -- Also 100 tokens are transferred from the @moneybag@ address. - expectedStringCallerBalance = 500 - 300 + 100 - expectedFailOrStoreBalance = 900 + 300 - 5 - expectedConstAddrBalance = initialConstAddrBalance + 5 - - getStorage @MText failOrStoreAddress @@== str - getBalance failOrStoreAddress @@== expectedFailOrStoreBalance - getBalance stringCallerAddress @@== expectedStringCallerBalance - getBalance constAddr @@== expectedConstAddrBalance - - -- Now let's transfer 100 tokens to stringCaller again. - -- This time execution should fail, because failOrStoreAndTransfer should fail - -- because its balance is greater than 1300. - expectFailedWith () $ - transferToStringCaller - where - stringCaller = $$(embedContract @MText @Address @() (inContractsDir "string_caller.tz")) - failOrStoreAndTransfer = - $$(embedContract @MText @MText @() (inContractsDir "fail_or_store_and_transfer.tz")) - -- Address hardcoded in 'failOrStoreAndTransfer.tz'. - constAddr = [ta|tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU|] diff --git a/morley-test/Test/Interpreter/TransferAndCreate.hs b/morley-test/Test/Interpreter/TransferAndCreate.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/TransferAndCreate.hs +++ /dev/null @@ -1,32 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'transfer_n_create.tz' contract. See [#643] -module Test.Interpreter.TransferAndCreate - ( test_transferAndCreate - ) where - -import Test.Tasty (TestTree) - -import Morley.Tezos.Address -import Test.Cleveland -import Test.Cleveland.Instances () -import Test.Util.Contracts - -test_transferAndCreate :: IO TestTree -test_transferAndCreate = - pure $ testScenario "'transfer_n_create.tz' performs origination after transfer" $ scenario do - contract <- importContract @() @Address @() (contractsDir "transfer_n_create.tz") - transferAndCreate <- originateSimple "transferAndCreate" constAddr contract - oldBalance <- getBalance constAddr - transferMoney transferAndCreate 10 - newBalance <- getBalance constAddr - newBalance - oldBalance @== 1 - newAddr <- getStorage @Address transferAndCreate - -- Here we check that origination was performed - () <- getStorage @() newAddr - pure () - --- Address hardcoded in 'transfer_n_create.tz'. -constAddr :: Address -constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe" diff --git a/morley-test/Test/Interpreter/Views.hs b/morley-test/Test/Interpreter/Views.hs deleted file mode 100644 --- a/morley-test/Test/Interpreter/Views.hs +++ /dev/null @@ -1,138 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on on-chain views. -module Test.Interpreter.Views - ( test_runtime - , test_step_constants - , test_recursion - , test_create_contract - , test_context_restore_on_exit - ) where - -import Fmt (Buildable, (+|), (|+)) -import Test.Tasty (TestTree, testGroup) - -import Morley.Tezos.Address -import Morley.Tezos.Core -import Test.Cleveland -import Test.Cleveland.Instances () -import Test.Cleveland.Lorentz.Types -import Test.Util.Contracts - --- Tests from Tezos --- --- Taken from https://gitlab.com/tezos/tezos/-/blob/6eef585d8e897b94b330323987ee0e6228189791/tests_python/tests_alpha/test_contract.py#L681 ----------------------------------------------------------------------------- - -amongTezosContracts :: FilePath -> FilePath -amongTezosContracts file = contractsDir "tezos_examples" "opcodes" file - -originateViewedContract - :: MonadCleveland caps m => m (ContractHandle Natural Natural ()) -originateViewedContract = - importContract (amongTezosContracts "view_toplevel_lib.tz") - >>= \c -> originate OriginateData - { odName = "viewedContract" - , odBalance = 777 - , odStorage = 3 :: Natural - , odContract = c - } - -test_runtime :: TestTree -test_runtime = testGroup "Basic interpreter logic" - [ checkContract "view_op_id" ((0, 0) :: (Natural, Natural)) (10, 3) - , checkContract "view_op_add" (42 :: Natural) 13 - , checkContract "view_fib" (0 :: Natural) 55 - , checkContract "view_mutual_recursion" (0 :: Natural) 20 - , checkContract "view_op_nonexistent_func" True False - , checkContract "view_op_nonexistent_addr" True False - , checkContract "view_op_toplevel_inconsistent_input_type" (5 :: Natural) 0 - , checkContract "view_op_toplevel_inconsistent_output_type" True False - ] - where - checkContract - :: (NiceStorage st, Eq st, Buildable st, AsRPC st ~ st) - => String -> st -> st -> TestTree - checkContract fileName initSt expected = - testScenario fileName $ scenario $ clarifyErrors ("For '" +| fileName |+ "'") do - viewedContract <- originateViewedContract - viewCaller - <- importContract @(Natural, Address) @_ @() (amongTezosContracts $ fileName <> ".tz") - >>= originateSimple "viewCaller" initSt - call viewCaller CallDefault (10, toAddress viewedContract) - getStorage viewCaller @@== expected - -test_step_constants :: TestTree -test_step_constants = - testScenario "Step constants contract" $ scenario do - alice <- newAddress auto - viewedContract <- originateViewedContract - viewCaller - <- importContract @Address @(Maybe ((Mutez, Mutez), ((Address, Address), Address))) @() - (amongTezosContracts "view_op_test_step_contants.tz") - >>= originateSimple "viewCaller" Nothing - withSender alice do - call viewCaller CallDefault (toAddress viewedContract) - let expectedSelfAddress = toAddress viewedContract - expectedSender = toAddress viewCaller - expectedSource = alice - getStorage viewCaller @@== Just - ( ( 0 - , 777 - ) - , ( ( expectedSelfAddress - , expectedSender - ) - , expectedSource - ) - ) - -test_recursion :: TestTree -test_recursion = - testScenario "Recursive call" $ scenario do - contract - <- importContract @() @() @() (amongTezosContracts "view_rec.tz") - >>= originateSimple "contract" () - call contract CallDefault () - & expectTransferFailure gasExhaustion - -test_create_contract :: TestTree -test_create_contract = - testScenario "Recursive call" $ scenario do - contractCreator - <- importContract @() @(Maybe Address) @() - (amongTezosContracts "create_contract_with_view.tz") - >>= originateSimple "contractCreator" Nothing - call contractCreator CallDefault () - contractAddr <- getStorage contractCreator >>= \case - Nothing -> failure "Unexpected outcome" - Just addr -> pure addr - - constViewObserver - <- importContract @(Natural, Address) @Natural @() - (amongTezosContracts "view_op_constant.tz") - >>= originateSimple "constViewObserver" 2 - call constViewObserver CallDefault (10, contractAddr) - - getStorage constViewObserver @@== 10 - --- In Tezos they have a lot of tests covering the fact that environment must --- be restored on view exist (the tests were added along with a bugfix), --- but we don't need this, we use 'ReaderT' that makes the issue hard to produce. -test_context_restore_on_exit :: TestTree -test_context_restore_on_exit = - testScenario "Context restores" $ scenario do - viewedContract <- originateViewedContract - selfAfterView - <- importContract @Address @Address @() - (amongTezosContracts "self_after_view.tz") - >>= \c -> originate OriginateData - { odName = "selfAfterView" - , odBalance = 1500 -- transferred by the contract further - , odStorage = toAddress viewedContract - , odContract = c - } - - call selfAfterView CallDefault (toAddress viewedContract) - getStorage selfAfterView @@== toAddress selfAfterView diff --git a/morley-test/Test/Macro.hs b/morley-test/Test/Macro.hs deleted file mode 100644 --- a/morley-test/Test/Macro.hs +++ /dev/null @@ -1,221 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Macro - ( unit_PAPAIR - , unit_UNPAPAIR - , unit_CADR - , unit_SET_CADR - , unit_MAP_CADR - , unit_mapPairLeaves - , unit_expand - , unit_expandValue - , test_carnAndCdrnExpandToGetN - ) where - -import Hedgehog (forAll, property, (===)) -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) - -import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), SrcPos, srcPos) -import Morley.Michelson.Macro -import Morley.Michelson.Untyped - (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), mkAnnotation, noAnn) - -import Test.Cleveland.Instances () - -defPos :: SrcPos -defPos = srcPos 1 1 - -defICS :: InstrCallStack -defICS = InstrCallStack [] defPos - --- TODO: it seems to me that these duplicated "where" blocks should be --- replaced with some reasonable mini-EDSL - at least to facilitate tests --- writing - and that would be a rather big refactoring. --- Dunno how to deal with this duplication otherwise. -{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} - -unit_PAPAIR :: Expectation -unit_PAPAIR = do - expandPapair defICS pair n n `shouldBe` [primEx $ PAIR n n n n] - expandPapair defICS (P leaf pair) n n `shouldBe` - [primEx $ DIP (expandMacro defICS $ PAPAIR pair n n), primEx $ PAIR n n n n] - expandList [mac $ PAPAIR (P pair leaf) n n] `shouldBe` - [WithSrcEx defICS $ SeqEx [primEx $ PAIR n n n n, primEx $ PAIR n n n n]] - expandList [mac $ PAPAIR (P pair pair) n n] `shouldBe` - [WithSrcEx defICS $ SeqEx [primEx (PAIR n n n n), - primEx (DIP [primEx (PAIR n n n n)]), - primEx (PAIR n n n n)]] - where - mac = flip Mac defPos - primEx = PrimEx - n = noAnn - leaf = F n - pair = P leaf leaf - -unit_UNPAPAIR :: Expectation -unit_UNPAPAIR = do - expandUnpapair defICS pair `shouldBe` - [primEx $ UNPAIR n n n n] - - expandList [mac $ UNPAPAIR $ UP UF pair] `shouldBe` - [WithSrcEx defICS $ SeqEx - [ primEx (UNPAIR n n n n) - , primEx (DIP [primEx (UNPAIR n n n n)]) - ] - ] - - expandList [mac $ UNPAPAIR $ UP pair UF] `shouldBe` - [WithSrcEx defICS $ SeqEx - [ primEx (UNPAIR n n n n) - , primEx (UNPAIR n n n n) - ] - ] - - expandList [mac $ UNPAPAIR $ UP pair pair] `shouldBe` - [WithSrcEx defICS $ SeqEx - [ primEx (UNPAIR n n n n) - , primEx (DIP [primEx $ UNPAIR n n n n]) - , primEx (UNPAIR n n n n) - ] - ] - where - mac = flip Mac defPos - primEx = PrimEx - n = noAnn - pair = UP UF UF - -unit_CADR :: Expectation -unit_CADR = do - expandCadr defICS ([A]) v f `shouldBe` [primEx $ CAR v f] - expandCadr defICS ([D]) v f `shouldBe` [primEx $ CDR v f] - expandCadr defICS (A:xs) v f `shouldBe` primEx (CAR n n) : expandMacro defICS (CADR xs v f) - expandCadr defICS (D:xs) v f `shouldBe` primEx (CDR n n) : expandMacro defICS (CADR xs v f) - where - primEx = PrimEx - v = "var" - f = "field" - n = noAnn - xs = [A, D] - -unit_SET_CADR :: Expectation -unit_SET_CADR = do - expandSetCadr defICS [A] v f `shouldBe` primEx <$> [ DUP noAnn, CAR noAnn f, DROP - , CDR "%%" noAnn, SWAP, PAIR noAnn v f "@"] - expandSetCadr defICS [D] v f `shouldBe` primEx <$> [ DUP noAnn, CDR noAnn f, DROP - , CAR "%%" noAnn, PAIR noAnn v "@" f] - expandSetCadr defICS (A:xs) v f `shouldBe` - primEx <$> [DUP noAnn, DIP (primEx carN : expandMacro defICS (SET_CADR xs noAnn f)), cdrN, SWAP, pairN] - expandSetCadr defICS (D:xs) v f `shouldBe` - primEx <$> [DUP noAnn, DIP (primEx cdrN : expandMacro defICS (SET_CADR xs noAnn f)), carN, pairN] - where - primEx = PrimEx - v = "var" - f = "field" - xs = [A, D] - carN = CAR "%%" noAnn - cdrN = CDR "%%" noAnn - pairN = PAIR noAnn v "@" "@" - -unit_MAP_CADR :: Expectation -unit_MAP_CADR = do - expandMapCadr defICS [A] v f ops `shouldBe` - primEx <$> [DUP noAnn, cdrN, DIP [primEx $ CAR noAnn f, SeqEx ops'], SWAP, PAIR noAnn v f "@"] - expandMapCadr defICS [D] v f ops `shouldBe` - concat [primEx <$> [DUP noAnn, CDR noAnn f], [SeqEx ops'], primEx <$> [SWAP, carN, PAIR noAnn v "@" f]] - expandMapCadr defICS (A:xs) v f ops `shouldBe` - primEx <$> [DUP noAnn, DIP (primEx carN : expandMacro defICS (MAP_CADR xs noAnn f ops)), cdrN, SWAP, pairN] - expandMapCadr defICS (D:xs) v f ops `shouldBe` - primEx <$> [DUP noAnn, DIP (primEx cdrN : expandMacro defICS (MAP_CADR xs noAnn f ops)), carN, pairN] - where - primEx = PrimEx - v = "var" - f = "field" - n = noAnn - xs = [A, D] - ops = [Prim (DUP n) defPos] - ops' = [WithSrcEx defICS $ PrimEx (DUP n)] - carN = CAR "%%" noAnn - cdrN = CDR "%%" noAnn - pairN = PAIR noAnn v "@" "@" - -unit_mapPairLeaves :: Expectation -unit_mapPairLeaves = do - mapPairLeaves [f, f] pair `shouldBe` P (F f) (F f) - mapPairLeaves annotations (P pair (F n)) `shouldBe` - P (P (leaf "field1") (leaf "field2")) (leaf "field3") - mapPairLeaves annotations (P pair pair) `shouldBe` - P (P (leaf "field1") (leaf "field2")) (P (leaf "field3") (F n)) - where - annotations = unsafe . mkAnnotation <$> ["field1", "field2", "field3"] - n = noAnn - f = "field" - leaf f' = F (unsafe . mkAnnotation $ f') - pair = P (F n) (F n) - -unit_expand :: Expectation -unit_expand = do - expand [LetName "a"] diip `shouldBe` expandedDiip - expand [LetName "a"] (prim $ IF [diip] [diip]) `shouldBe` (primEx $ IF [expandedDiip] [expandedDiip]) - expand [LetName "a"] (Seq [diip, diip] defPos) `shouldBe` (WithSrcEx aIcs $ SeqEx $ [expandedDiip, expandedDiip]) - where - aIcs = InstrCallStack [LetName "a"] defPos - prim = flip Prim defPos - primEx = WithSrcEx aIcs . PrimEx - mac = flip Mac defPos - diip :: ParsedOp - diip = mac (DIIP 2 [prim SWAP]) - expandedDiip :: ExpandedOp - expandedDiip = primEx (DIPN 2 [primEx SWAP]) - -unit_expandValue :: Expectation -unit_expandValue = do - expandValue parsedPair `shouldBe` expandedPair - expandValue parsedPapair `shouldBe` expandedPapair - expandValue parsedLambdaWithMac `shouldBe` expandedLambdaWithMac - where - mac = flip Mac defPos - primEx = PrimEx - - parsedPair :: Value' ParsedOp - parsedPair = ValuePair (ValueInt 5) (ValueInt 5) - - expandedPair :: Value - expandedPair = ValuePair (ValueInt 5) (ValueInt 5) - - parsedPapair :: Value' ParsedOp - parsedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) - - expandedPapair :: Value - expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) - - parsedLambdaWithMac :: Value' ParsedOp - parsedLambdaWithMac = ValueLambda $ - one (mac (PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn))) noAnn noAnn)) - - expandedLambdaWithMac :: Value - expandedLambdaWithMac = ValueLambda . one $ WithSrcEx defICS $ SeqEx - [ primEx $ DIP [primEx $ PAIR noAnn noAnn noAnn noAnn] - , primEx $ PAIR noAnn noAnn noAnn noAnn - ] - -test_carnAndCdrnExpandToGetN :: [TestTree] -test_carnAndCdrnExpandToGetN = - [ testProperty "CAR k to GET 2k+1" $ property do - k <- forAll $ Gen.word $ Range.linear 0 100 - n <- forAll $ Gen.U.genAnnotation - expand' (CARN n k) === primEx (GETN n $ 2 * k + 1) - , testProperty "CDR k to GET 2k" $ property do - k <- forAll $ Gen.word $ Range.linear 0 100 - n <- forAll $ Gen.U.genAnnotation - expand' (CDRN n k) === primEx (GETN n $ 2 * k) - ] - where - primEx = WithSrcEx defICS . SeqEx . one . PrimEx - mac = flip Mac defPos - expand' = expand [] . mac diff --git a/morley-test/Test/Michelson/Parser/Value.hs b/morley-test/Test/Michelson/Parser/Value.hs deleted file mode 100644 --- a/morley-test/Test/Michelson/Parser/Value.hs +++ /dev/null @@ -1,25 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Michelson.Parser.Value - ( test_exponentialBacktracking - ) where - -import Test.Tasty (TestTree, localOption, mkTimeout) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Morley.Michelson.Parser as P -import Morley.Michelson.Untyped.Value - -millisec :: Integer -millisec = 1000 - -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 \ - \(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] - - parsedValue @?= Right expected diff --git a/morley-test/Test/Michelson/Runtime.hs b/morley-test/Test/Michelson/Runtime.hs deleted file mode 100644 --- a/morley-test/Test/Michelson/Runtime.hs +++ /dev/null @@ -1,170 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for "Morley.Michelson.Runtime". - -module Test.Michelson.Runtime - ( test_executorPure - ) where - -import Control.Lens (at) -import Data.Default (def) -import Fmt (pretty) -import Test.HUnit (Assertion, assertFailure, (@?), (@?=)) -import Test.Hspec.Expectations (Expectation, expectationFailure) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Morley.Michelson.Interpret - (ContractEnv(..), InterpretResult(..), handleContractReturn, interpret) -import Morley.Michelson.Runtime hiding (transfer) -import Morley.Michelson.Runtime.Dummy - (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter, dummyLevel, dummyMaxSteps, dummyNow, - dummyOrigination) -import Morley.Michelson.Runtime.GState (BigMapCounter, GState(..), initGState) -import Morley.Michelson.Text (MText) -import Morley.Michelson.Typed -import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) -import Morley.Tezos.Address -import Test.Cleveland.Instances () - -test_executorPure :: IO [TestTree] -test_executorPure = do - pure - [ testGroup "Updates storage value of executed contract" $ - [ testCase "contract1" $ updatesStorageValue contractAux1 - , testCase "contract2" $ updatesStorageValue contractAux2 - ] - , testCase "Succeeds to originate the same contract twice, with different addresses" - succeedsToOriginateTwice - , testCase "Transfer of 0tz from unknown address is allowed" transferFromUnknown - ] - ----------------------------------------------------------------------------- --- Test code ----------------------------------------------------------------------------- - --- | Data type, that containts contract and its auxiliary data. -data ContractAux cp st = ContractAux - { caContract :: T.Contract cp st - , caBigMapCounter :: BigMapCounter - , caEnv :: ContractEnv - , caStorage :: T.Value st - , caParameter :: T.Value cp - } - -updatesStorageValue - :: (ParameterScope cp, StorageScope st) - => ContractAux cp st -> Assertion -updatesStorageValue ca = either (assertFailure . pretty) handleResult $ do - let - ce = caEnv ca - origination = contractAuxToOrigination ca - txData = TxData - { tdSenderAddress = ceSender ce - , tdParameter = TxTypedParam $ caParameter ca - , tdEntrypoint = DefEpName - , tdAmount = 100 - } - - runExecutorM dummyNow dummyLevel dummyMaxSteps initGState $ do - addr <- executeGlobalOrigination origination - executeGlobalOperations def [TransferOp $ TransferOperation addr txData 1] - return addr - where - toNewStorage :: InterpretResult -> SomeValue - toNewStorage InterpretResult {..} = SomeValue $ iurNewStorage - - handleResult :: (ExecutorRes, Address) -> Assertion - handleResult (ir, addr) = do - expectedValue <- - either (assertFailure . pretty) (pure . toNewStorage) $ - handleContractReturn $ - interpret - (caContract ca) - unsafeEpcCallRoot - (caParameter ca) - (caStorage ca) - dummyGlobalCounter - (caBigMapCounter ca) - (caEnv ca) - case gsAddresses (_erGState ir) ^. at addr of - Nothing -> expectationFailure $ "Address not found: " <> pretty addr - Just (ASContract ContractState{..}) -> SomeValue csStorage @?= expectedValue - Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr - -succeedsToOriginateTwice :: Expectation -succeedsToOriginateTwice = either (assertFailure . pretty) handleResult $ do - runExecutorM dummyNow dummyLevel dummyMaxSteps initGState $ do - addr1 <- executeGlobalOrigination origination1 - addr2 <- executeGlobalOrigination origination2 - return (addr1, addr2) - where - contract = caContract contractAux1 - origination1 = dummyOrigination (caStorage contractAux1) contract 0 - origination2 = dummyOrigination (caStorage contractAux1) contract 1 - - handleResult :: (ExecutorRes, (Address, Address)) -> Assertion - handleResult (_, (addr1, addr2)) = - addr1 /= addr2 @? "Two originated addresses are not different" - -transferFromUnknown :: Assertion -transferFromUnknown = do - let - res = runExecutorM dummyNow dummyLevel dummyMaxSteps initGState $ do - addr <- executeGlobalOrigination origination - executeGlobalOperations def [TransferOp $ TransferOperation addr txData 1] - - whenLeft res $ - assertFailure . pretty - where - ca = contractAux1 - origination = contractAuxToOrigination ca - txData = - TxData - { tdSenderAddress = detGenKeyAddress "transferFromUnknown" - , tdParameter = TxTypedParam $ caParameter ca - , tdEntrypoint = DefEpName - , tdAmount = 0 - } - ----------------------------------------------------------------------------- --- Data ----------------------------------------------------------------------------- - -contractAux1 :: ContractAux 'TString 'TBool -contractAux1 = ContractAux - { caContract = contract - , caBigMapCounter = dummyBigMapCounter - , caEnv = dummyContractEnv - , caStorage = toVal True - , caParameter = toVal ("aaa" :: MText) - } - where - contract :: Contract 'TString 'TBool - contract = Contract - { cParamNotes = starParamNotes - , cStoreNotes = starNotes - , cCode = - CDR `Seq` NIL `Seq` PAIR - , cEntriesOrder = def - , cViews = def - } - -contractAux2 :: ContractAux 'TString 'TBool -contractAux2 = contractAux1 - { caContract = (caContract contractAux1) - { cCode = - CDR `Seq` NOT `Seq` NIL `Seq` PAIR - } - } - -contractAuxToOrigination - :: (ParameterScope cp , StorageScope st) - => ContractAux cp st -> OriginationOperation -contractAuxToOrigination ca = - let contract = caContract ca - ce = caEnv ca - originationOp = dummyOrigination (caStorage ca) contract dummyGlobalCounter - in originationOp {ooBalance = ceBalance ce} diff --git a/morley-test/Test/Michelson/Show.hs b/morley-test/Test/Michelson/Show.hs deleted file mode 100644 --- a/morley-test/Test/Michelson/Show.hs +++ /dev/null @@ -1,102 +0,0 @@ --- 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 deleted file mode 100644 --- a/morley-test/Test/Michelson/Text.hs +++ /dev/null @@ -1,166 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on 'MText'. -module Test.Michelson.Text - ( test_Roundtrip - , unit_mkMText - , unit_parse - , unit_mkMTextCut - , unit_QuasiQuoter - , unit_mt - ) where - -import Fmt (Buildable, pretty) -import Test.HUnit (Assertion, (@?), (@?=)) -import Test.Tasty (TestTree) -import Text.Megaparsec qualified as P - -import Hedgehog.Gen.Michelson (genMText) -import Morley.Michelson.Parser -import Morley.Michelson.Text -import Morley.Michelson.Untyped qualified as U -import Morley.Util.Text (dquotes) -import Test.Cleveland.Instances () - -import Test.Util.Hedgehog (roundtripTree) - --- | Parse string literal content to 'MText'. -parseMTextTest :: HasCallStack => Text -> Either () MText -parseMTextTest t = - first (const ()) $ - expectString <$> parseNoEnv @() (stringLiteral <* P.eof) codeSrc (dquotes t) - where - expectString = \case - U.ValueString t' -> t' - o -> error $ "Expected string, but got " <> pretty o - --- | 'MText' rountrip conversions. -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ roundtripTree genMText writeMText parseMTextTest ] - --- | Check value against the given predicate. -(@??) :: (Buildable a, HasCallStack) => a -> (a -> Bool) -> Assertion -(@??) val predicate = - predicate val @? - ("Predicate does not hold for value " <> pretty val) - -unit_mkMText :: Assertion -unit_mkMText = do - mkMText "" - @?= Right (UnsafeMText "") - mkMText "a ba" - @?= Right (UnsafeMText "a ba") - mkMText "a\nb" - @?= Right (UnsafeMText "a\nb") - mkMText "a\\nb" - @?= Right (UnsafeMText "a\\nb") - mkMText "\\\\" - @?= Right (UnsafeMText "\\\\") - mkMText "\"" - @?= Right (UnsafeMText "\"") - mkMText "\r" - @?? isLeft - mkMText "\t" - @?? isLeft - mkMText (toText @String [toEnum 5]) - @?? isLeft - mkMText (toText @String [toEnum 127]) - @?? isLeft - mkMText (toText @String [toEnum 300]) - @?? isLeft - -unit_parse :: Assertion -unit_parse = do - parseMTextTest "" - @?= Right (UnsafeMText "") - parseMTextTest "a ba" - @?= Right (UnsafeMText "a ba") - parseMTextTest "a\nb" - @?? isLeft - parseMTextTest "a\\nb" - @?= Right (UnsafeMText "a\nb") - parseMTextTest "\\" - @?? isLeft - parseMTextTest "\\\\" - @?= Right (UnsafeMText "\\") - parseMTextTest "\"" - @?? isLeft - parseMTextTest "\\\"" - @?= Right (UnsafeMText "\"") - parseMTextTest "\r" - @?? isLeft - parseMTextTest "\t" - @?? isLeft - parseMTextTest (toText @String [toEnum 5]) - @?? isLeft - parseMTextTest (toText @String [toEnum 127]) - @?? isLeft - parseMTextTest (toText @String [toEnum 300]) - @?? isLeft - -unit_mkMTextCut :: Assertion -unit_mkMTextCut = do - mkMTextCut "" - @?= UnsafeMText "" - mkMTextCut "a ba" - @?= UnsafeMText "a ba" - mkMTextCut "a\nb" - @?= UnsafeMText "a\nb" - mkMTextCut "a\\nb" - @?= UnsafeMText "a\\nb" - mkMTextCut "\\" - @?= UnsafeMText "\\" - mkMTextCut "\\\\" - @?= UnsafeMText "\\\\" - mkMTextCut "\"" - @?= UnsafeMText "\"" - mkMTextCut "\\\"" - @?= UnsafeMText "\\\"" - mkMTextCut "a\rb" - @?= UnsafeMText "ab" - mkMTextCut "c\td\r" - @?= UnsafeMText "cd" - mkMTextCut (toText @String [toEnum 5]) - @?= UnsafeMText "" - mkMTextCut (toText @String [toEnum 127]) - @?= UnsafeMText "" - mkMTextCut (toText @String [toEnum 300, 'A']) - @?= UnsafeMText "A" - -unit_QuasiQuoter :: Assertion -unit_QuasiQuoter = do - qqMText "" - @?= Right "" - qqMText "a ba" - @?= Right "a ba" - qqMText "a\nb" - @?? isLeft - qqMText "a\\nb" - @?= Right "a\nb" - qqMText "\\" - @?? isLeft - qqMText "\\\\" - @?= Right "\\" - qqMText "\"" - @?= Right "\"" - qqMText "\\\"" - @?? isLeft - qqMText "\r" - @?? isLeft - qqMText "\t" - @?? isLeft - qqMText [toEnum 5] - @?? isLeft - qqMText [toEnum 127] - @?? isLeft - qqMText [toEnum 300] - @?? isLeft - -unit_mt :: Assertion -unit_mt = do - [mt|aba|] - @?= UnsafeMText "aba" - [mt| a |] - @?= UnsafeMText " a " diff --git a/morley-test/Test/Michelson/Typed/AnnotatedValue.hs b/morley-test/Test/Michelson/Typed/AnnotatedValue.hs deleted file mode 100644 --- a/morley-test/Test/Michelson/Typed/AnnotatedValue.hs +++ /dev/null @@ -1,279 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Michelson.Typed.AnnotatedValue - ( unit_variant_read - , unit_variant_update - , unit_field_read - , unit_field_update - , unit_nodes - , unit_asList - , unit_asMap - ) - where - -import Control.Lens (_Just, each, ix, (+~), (<>~), (^@..)) -import Fmt (Buildable, GenericBuildable(..)) -import Test.Cleveland.Instances () -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) -import Morley.Michelson.Typed.Haskell.Value (BigMap, IsoValue, ToT, toVal) - ----------------------------------------------------------------------------- --- Sum types ----------------------------------------------------------------------------- - -data Param - = P1 Integer - | P2 MText - | P3 (MText, Natural) - | P4 NestedParam - deriving stock Generic - deriving anyclass (IsoValue) - deriving Buildable via (GenericBuildable Param) - -data NestedParam - = NP1 Integer - | NP2 Natural - deriving stock Generic - deriving anyclass (IsoValue) - deriving Buildable via (GenericBuildable NestedParam) - -paramNotes :: Notes (ToT Param) -paramNotes = - [notes| - or - (or (int %p1) - (string %p2) - ) - (or (pair %p3 string nat) - (or %p4 (int %p1) (nat %p2)) - ) - |] - -nestedParamNotes :: Notes (ToT NestedParam) -nestedParamNotes = [notes|or (int %p1) (nat %p2)|] - -unit_variant_read :: IO () -unit_variant_read = do - let mkParam param = SomeAnnotatedValue paramNotes (toVal param) - - let p1 = mkParam $ P1 1 - p1 ^.. variant "p1" @?= one (SomeAnnotatedValue starNotes (toVal @Integer 1)) - p1 ^.. variant "p2" @?= [] - p1 ^.. variant "p3" @?= [] - p1 ^.. variant "p4" @?= [] - - let p2 = mkParam $ P2 "a" - p2 ^.. variant "p1" @?= [] - p2 ^.. variant "p2" @?= one (SomeAnnotatedValue starNotes (toVal @MText "a")) - p2 ^.. variant "p3" @?= [] - p2 ^.. variant "p4" @?= [] - - let p3 = mkParam $ P3 ("a", 1) - p3 ^.. variant "p1" @?= [] - p3 ^.. variant "p2" @?= [] - p3 ^.. variant "p3" @?= one (SomeAnnotatedValue starNotes (toVal @(MText, Natural) ("a", 1))) - p3 ^.. variant "p4" @?= [] - - let p4_1 = mkParam $ P4 (NP1 1) - p4_1 ^.. variant "p1" @?= [] - p4_1 ^.. variant "p2" @?= [] - p4_1 ^.. variant "p3" @?= [] - p4_1 ^.. variant "p4" @?= one (SomeAnnotatedValue nestedParamNotes (toVal (NP1 1))) - p4_1 ^.. variant "p4" . variant "p1" @?= one (SomeAnnotatedValue starNotes (toVal @Integer 1)) - p4_1 ^.. variant "p4" . variant "p2" @?= [] - - let p4_2 = mkParam $ P4 (NP2 1) - p4_2 ^.. variant "p1" @?= [] - p4_2 ^.. variant "p2" @?= [] - p4_2 ^.. variant "p3" @?= [] - p4_2 ^.. variant "p4" @?= one (SomeAnnotatedValue nestedParamNotes (toVal (NP2 1))) - p4_2 ^.. variant "p4" . variant "p1" @?= [] - p4_2 ^.. variant "p4" . variant "p2" @?= one (SomeAnnotatedValue starNotes (toVal @Natural 1)) - -unit_variant_update :: IO () -unit_variant_update = do - let mkParam param = SomeAnnotatedValue paramNotes (toVal param) - - (mkParam (P1 1) & variant "p1" . castTo @Integer . value +~ 99) - @?= mkParam (P1 100) - - (mkParam (P2 "a") & variant "p2" . castTo @MText . value <>~ "!") - @?= mkParam (P2 "a!") - - (mkParam (P3 ("a", 1)) & variant "p3" . castTo @(MText, Natural) . value . _1 <>~ "!") - @?= mkParam (P3 ("a!", 1)) - - (mkParam (P4 (NP1 1)) & variant "p4" . variant "p1" . castTo @Integer . value +~ 99) - @?= mkParam (P4 (NP1 100)) - - (mkParam (P4 (NP2 1)) & variant "p4" . variant "p2" . castTo @Natural . value +~ 99) - @?= mkParam (P4 (NP2 100)) - ----------------------------------------------------------------------------- --- Product types ----------------------------------------------------------------------------- - -data Storage = Storage - { sField1 :: Integer - , sField2 :: (MText, Natural) - , sField3 :: Maybe Integer - , sField4 :: Nested - } - deriving stock Generic - deriving anyclass (IsoValue) - deriving Buildable via (GenericBuildable Storage) - -data Nested = Nested - { nField1 :: MText - , nField2 :: Integer - } - deriving stock Generic - deriving anyclass (IsoValue) - deriving Buildable via (GenericBuildable Nested) - -storageNotes :: Notes (ToT Storage) -storageNotes = - [notes| - pair - (pair - (int %field1) - (pair %field2 string nat) - ) - (pair - (option %field3 int) - (pair %field4 - (string %field1) - (int %field2) - ) - ) - |] - -nestedNotes :: Notes (ToT Nested) -nestedNotes = [notes|pair (string %field1) (int %field2)|] - -storage :: Storage -storage = Storage - { sField1 = 1 - , sField2 = ("a", 2) - , sField3 = Just 3 - , sField4 = Nested - { nField1 = "b" - , nField2 = 4 - } - } - -storageSav :: SomeAnnotatedValue -storageSav = SomeAnnotatedValue storageNotes (toVal storage) - -unit_field_read :: IO () -unit_field_read = do - storageSav ^@.. fields @?= - [ ("field1", SomeAnnotatedValue starNotes (toVal $ sField1 storage)) - , ("field2", SomeAnnotatedValue starNotes (toVal $ sField2 storage)) - , ("field3", SomeAnnotatedValue starNotes (toVal $ sField3 storage)) - , ("field4", SomeAnnotatedValue nestedNotes (toVal $ sField4 storage)) - ] - - storageSav ^@.. field "field4" . fields @?= - [ ("field1", SomeAnnotatedValue starNotes (toVal $ nField1 $ sField4 storage)) - , ("field2", SomeAnnotatedValue starNotes (toVal $ nField2 $ sField4 storage)) - ] - -unit_field_update :: IO () -unit_field_update = do - (storageSav & field "field1" . castTo @Integer . value +~ 100) - @?= SomeAnnotatedValue storageNotes - (toVal $ storage { sField1 = 101 }) - - (storageSav & field "field2" . castTo @(MText, Natural) . value . _2 +~ 100) - @?= SomeAnnotatedValue storageNotes - (toVal $ storage { sField2 = ("a", 102) }) - - (storageSav & field "field3" . castTo @(Maybe Integer) . value . _Just +~ 100) - @?= SomeAnnotatedValue storageNotes - (toVal $ storage { sField3 = Just 103 }) - - (storageSav & field "field4" . field "field1" . castTo @MText . value <>~ "!") - @?= SomeAnnotatedValue storageNotes - (toVal $ storage { sField4 = (sField4 storage) { nField1 = "b!" } }) - - (storageSav & field "field4" . field "field2" . castTo @Integer . value +~ 100) - @?= SomeAnnotatedValue storageNotes - (toVal $ storage { sField4 = (sField4 storage) { nField2 = 104 } }) - -unit_nodes :: IO () -unit_nodes = do - storageSav ^@.. nodes @?= - [ ("", SomeAnnotatedValue - [notes|pair (int %field1) (pair %field2 string nat)|] - (toVal @(Integer, (MText, Natural)) $ (1, ("a", 2))) - ) - , ("", SomeAnnotatedValue - [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)) - , ("field2", SomeAnnotatedValue starNotes (toVal $ sField2 storage)) - , ("", SomeAnnotatedValue starNotes (toVal @MText "a")) - , ("", SomeAnnotatedValue starNotes (toVal @Natural 2)) - , ("field3", SomeAnnotatedValue starNotes (toVal $ sField3 storage)) - , ("field4", SomeAnnotatedValue nestedNotes (toVal $ sField4 storage)) - , ("field1", SomeAnnotatedValue starNotes (toVal $ nField1 $ sField4 storage)) - , ("field2", SomeAnnotatedValue starNotes (toVal $ nField2 $ sField4 storage)) - ] - - storageSav ^.. node "field1" @?= - [ SomeAnnotatedValue starNotes (toVal $ sField1 storage) - , SomeAnnotatedValue starNotes (toVal $ nField1 $ sField4 storage) - ] - ----------------------------------------------------------------------------- --- Collections ----------------------------------------------------------------------------- - -data Collections = Collections - { cListField :: [Integer] - , cMapField :: Map MText Natural - , cBigMapField :: BigMap MText Natural - } - deriving stock Generic - deriving anyclass (IsoValue) - deriving Buildable via (GenericBuildable Collections) - -collectionsNotes :: Notes (ToT Collections) -collectionsNotes = - [notes| - pair - (list %listField int) - (map %mapField string nat) - (big_map %bigMapField string nat) - |] - -collectionsSav :: SomeAnnotatedValue -collectionsSav = - SomeAnnotatedValue - collectionsNotes - (toVal Collections - { cListField = [1, 2, 3] - , cMapField = one ("b", 3) - , cBigMapField = one ("c", 4) - } - ) - -unit_asList :: IO () -unit_asList = do - collectionsSav ^.. field "listField" . asList . each . castTo @Integer . value - @?= [1, 2, 3] - -unit_asMap :: IO () -unit_asMap = do - collectionsSav ^? field "mapField" . asMap @MText . ix "b" . castTo @Natural . value - @?= Just 3 - collectionsSav ^? field "bigMapField" . asMap @MText . ix "c" . castTo @Natural . value - @?= Just 4 diff --git a/morley-test/Test/Michelson/Typed/Convert.hs b/morley-test/Test/Michelson/Typed/Convert.hs deleted file mode 100644 --- a/morley-test/Test/Michelson/Typed/Convert.hs +++ /dev/null @@ -1,101 +0,0 @@ --- 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 Data.Vinyl.Core (Rec(..)) -import Test.HUnit (assertEqual, (@?=)) -import Test.Hspec () -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 Morley.Michelson.Typed.Value (Value'(..)) -import Morley.Michelson.Untyped qualified as U -import Test.Cleveland.Instances () - -annA, annB :: U.Annotation a -annA = "a" -annB = "b" - -test_sub :: TestTree -test_sub = - testCase "SUB accepts one annotation" $ - assertEqual "SUB accepts one annotation" (instrToOps sub) subExpected - where - sub = PUSH (VInt 9) `Seq` PUSH (VInt 8) `Seq` InstrWithVarNotes (annA :| []) SUB - subExpected = - [ U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TInt U.noAnn) (U.ValueInt 9) - , U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TInt U.noAnn) (U.ValueInt 8) - , 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 - assertEqual "SHA256 accepts one annotation" (instrToOps sha256) sha256Expected - assertEqual "SHA512 accepts one annotation" (instrToOps sha512) sha512Expected - where - push = U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TBytes U.noAnn) (U.ValueBytes $ U.InternalByteString $ "foo") - sha256 = PUSH (VBytes "foo") `Seq` InstrWithVarNotes (annA :| []) SHA256 - sha256Expected = [push, U.PrimEx $ U.SHA256 annA] - sha512 = PUSH (VBytes "foo") `Seq` InstrWithVarNotes (annA :| []) SHA512 - sha512Expected = [push, U.PrimEx $ U.SHA512 annA] - -test_arith :: TestTree -test_arith = testCase "arithmetic operators have proper annotations" $ - zipWithM_ (assertEqual "single annotation in arithmetic works") - (instrToOps <$> instrCmp) - instrCmpExpected - where - instr = - InstrWithVarNotes (annA :| []) (PUSH (VInt 2)) - `Seq` InstrWithVarNotes (annB :| []) (PUSH (VInt 1)) - instrExpected = - [ U.PrimEx $ U.PUSH annA (U.Ty U.TInt U.noAnn) (U.ValueInt 2) - , U.PrimEx $ U.PUSH annB (U.Ty U.TInt U.noAnn) (U.ValueInt 1) - ] - instrCmp = mkTArith <$> arithTOps - instrCmpExpected = mkUArith <$> arithUOps - - -- Signature omitted due to being too cumbersome to read. - mkTArith op = instr `Seq` InstrWithVarNotes (annA :| []) op - - mkUArith :: (U.VarAnn -> U.ExpandedInstr) -> [U.ExpandedOp] - mkUArith op = instrExpected <> [U.PrimEx (op annA)] - - 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 deleted file mode 100644 --- a/morley-test/Test/Michelson/Typed/Util.hs +++ /dev/null @@ -1,130 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Michelson.Typed.Util'. - -module Test.Michelson.Typed.Util - ( unit_linearizeLeft_sample - , 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) - -import Hedgehog (Property) -import Test.HUnit (Assertion, assertFailure, (@?), (@?=)) - -import Morley.Michelson.Typed -import Test.Cleveland.Michelson (meanTimeUpperBoundPropNF, sec) - -unit_linearizeLeft_sample :: Assertion -unit_linearizeLeft_sample = - isLeftLinear (linearizeLeft (rightLinear 3)) @? "Failed to linearize" - -isLeftLinear :: Instr inp out -> Bool -isLeftLinear (Seq _ (Seq {})) = False -isLeftLinear (Seq a _) = isLeftLinear a -isLeftLinear _ = True - -rightLinear :: Word -> Instr '[ 'TUnit, 'TUnit ] '[ 'TUnit, 'TUnit] -rightLinear = go - where - go 0 = SWAP - go n = Seq SWAP (go (n - 1)) - -hprop_linearizeLeft_performance :: Property -hprop_linearizeLeft_performance = - meanTimeUpperBoundPropNF (sec 10) (linearizeLeft . rightLinear) 300000 - --- Use 'dfsFoldInstr' to count the number of the @UNIT@ instructions. -unit_dfsInstr_counter :: Assertion -unit_dfsInstr_counter = do - dfsFoldInstr (settings True) step instr @?= Sum 3 - dfsFoldInstr (settings False) step instr @?= Sum 2 - where - settings goToValues = - def - { dsGoToValues = goToValues - } - - step :: Instr a b -> Sum Word - step = \case - UNIT -> Sum 1 - _ -> mempty - - instr = UNIT `Seq` DUP `Seq` DIP UNIT `Seq` DROP `Seq` PUSH v - - v :: Value $ 'TPair 'TUnit $ 'TLambda 'TBool 'TBool - v = VPair (VUnit, (VLam $ RfNormal $ UNIT `Seq` DROP)) - -unit_dfsInstr_meta :: Assertion -unit_dfsInstr_meta = do - 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 - Seq CAR (Seq (Meta str' NIL) PAIR) -> matchStr str' - _ -> assertFailure @() "Failed to match output" - getProduct prod @?= 120 - where - str :: String - str = "preserve me" - - matchStr :: SomeMeta -> Assertion - matchStr (SomeMeta a) = case cast a of - Nothing -> assertFailure "Failed to cast string" - Just a' -> a' @?= str - - nilOp = NIL @('TList 'TOperation) - input = - Meta (SomeMeta (1 :: Word)) (Seq - (Meta (SomeMeta (2 :: Word)) CAR) - (Meta (SomeMeta (3 :: Word)) (Seq - (Meta (SomeMeta str) (Meta (SomeMeta (4 :: Word)) nilOp)) - (Meta (SomeMeta (5 :: Word)) PAIR)))) - - go :: Instr i o -> Writer (Product Word) (Instr i o) - go = \case - 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 deleted file mode 100644 --- a/morley-test/Test/Michelson/Typed/Value.hs +++ /dev/null @@ -1,35 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on 'Value'. -module Test.Michelson.Typed.Value - ( test_eqValueExt - ) where - -import Test.HUnit (assertBool) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -import Morley.Michelson.Text -import Morley.Michelson.Typed.Haskell.Value -import Morley.Michelson.Typed.Value -import Test.Cleveland.Instances () - -test_eqValueExt :: [TestTree] -test_eqValueExt = - [ testCase "Simple" $ - assertBool "Occured to be not reflexive" $ - toVal @Integer 5 `eqValueExt` toVal @Integer 5 - - , testCase "Complex" $ - assertBool "Occured to be not reflexive" $ - toVal ("a" :: MText, 5 :: Integer) - `eqValueExt` - toVal ("a" :: MText, 5 :: Integer) - - , testCase "Types do not matter if content is the same" $ - -- Not sure this property is desired, leaving a test just for - -- illustration purposes - assertBool "Unexpectedly equal" . not $ - toVal ([] @Integer) `eqValueExt` toVal ([] @MText) - ] diff --git a/morley-test/Test/Morley/Expression.hs b/morley-test/Test/Morley/Expression.hs deleted file mode 100644 --- a/morley-test/Test/Morley/Expression.hs +++ /dev/null @@ -1,557 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Micheline.Expression'. - -module Test.Morley.Expression - ( test_Roundtrip_binary - , test_Roundtrip_expression - , test_Roundtrip_JSON - , test_ToJSON_omits_empty_lists - , test_fromExpression - , 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 Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Singletons (demote) -import Data.Text qualified as T -import Hedgehog (Gen) -import Test.Hspec.Expectations (shouldBe) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) - -import Hedgehog.Gen.Michelson.Typed (genSimpleInstr, genValueInt, genValueMutez, genValueUnit) -import Hedgehog.Gen.Michelson.Untyped (genValidType) -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 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 (fromHex) -import Test.Util.Hedgehog (roundtripTree) - -testJSON - :: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a) - => Gen a -> TestTree -testJSON genA = roundtripTree @a genA encode eitherDecode - --- | Test that 'M.fromExpression' is inverse of 'M.toExpression' -roundtripExpression - :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a) - => Gen a -> TestTree -roundtripExpression genA = roundtripTree @a genA M.toExpression (M.fromExpression) - --- | Test that converting something to 'M.Expression', then to JSON, --- then decoding this JSON and converting back to the original type --- returns the original value. -roundtripExpressionJSON - :: forall a. (Eq a, Show a, M.ToExpression a, M.FromExpression a, Typeable a) - => Gen a -> TestTree -roundtripExpressionJSON genA = roundtripTree @a genA - (encode . M.toExpression) - (first displayException . M.fromExpression <=< eitherDecode) - -testBinary :: Gen M.Expression -> TestTree -testBinary genA = roundtripTree genA M.encodeExpression' M.eitherDecodeExpression - -test_Roundtrip_JSON :: [TestTree] -test_Roundtrip_JSON = - [ testJSON M.genExprAnnotation - , testJSON M.genExpression - , testJSON M.genMichelinePrimAp - , roundtripExpressionJSON @(T.Value $ T.ToT Integer) genValueInt - , roundtripExpressionJSON @(T.Value $ T.ToT Mutez) genValueMutez - , roundtripExpressionJSON @(T.Value $ T.ToT ()) genValueUnit - , roundtripExpressionJSON @(T.Instr '[T.ToT Mutez] '[T.ToT Mutez]) genSimpleInstr - , roundtripExpressionJSON (T.fromUType <$> genValidType) - , roundtripExpressionJSON genValidType - ] - -test_ToJSON_omits_empty_lists :: TestTree -test_ToJSON_omits_empty_lists = - testCase "ToJSON omits empty lists" $ do - let actual = toJSON . M.toExpression $ T.toVal (Nothing :: Maybe Integer) - let expected = object ["prim" .= String "None"] - - actual @?= expected - -test_Roundtrip_binary :: [TestTree] -test_Roundtrip_binary = - [ testBinary M.genExpression - ] - -test_Roundtrip_expression :: [TestTree] -test_Roundtrip_expression = - [ roundtripExpression @(T.Value $ T.ToT Integer) genValueInt - , roundtripExpression @(T.Value $ T.ToT Mutez) genValueMutez - , roundtripExpression @(T.Value $ T.ToT ()) genValueUnit - , roundtripExpression @(T.Instr '[T.ToT Mutez] '[T.ToT Mutez]) genSimpleInstr - , roundtripExpression @T.T (T.fromUType <$> genValidType) - , roundtripExpression genValidType - ] - -test_fromExpression :: [TestTree] -test_fromExpression = - -- These michelson expressions are generated using commands like the following: - -- - -- > tezos-client convert data 'Pair 1 2 "Hi"' from michelson to json - -- > tezos-client convert data 'pair int nat string' from michelson to json - [ testGroup "Value t" - [ testCase "Converting 'Pair' expression with >2 args into right-combed pair" $ do - fromExpressionTest - (T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi"))) - [aesonQQ| - { "prim": "Pair", "args": [ { "int": "1" }, { "int": "2" }, { "string": "Hi" } ] } - |] - , testCase "Converting nested 'Pair' expression into right-combed pair" $ do - fromExpressionTest - (T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi"))) - [aesonQQ| - { "prim": "Pair", - "args": - [ { "int": "1" }, - { "prim": "Pair", "args": [ { "int": "2" }, { "string": "Hi" } ] } ] - } - |] - , testCase "Converting list expression into right-combed pair" $ do - fromExpressionTest - (T.toVal @(Integer, (Natural, MText)) (1, (2, "Hi"))) - [aesonQQ| - [ { "int": "1" }, { "int": "2" }, { "string": "Hi" } ] - |] - ] - , testGroup "Type" - [ testCase "Converting 'pair' type expression with >2 args into right-combed pair type" $ do - fromExpressionTest - (T.toUType $ demote @(T.ToT (Integer, (Natural, MText)))) - [aesonQQ| - { "prim": "pair", - "args": [ { "prim": "int" }, { "prim": "nat" }, { "prim": "string" } ] } - |] - , testCase "Converting nested 'pair' type expression into right-combed pair type" $ do - fromExpressionTest - (T.toUType $ demote @(T.ToT (Integer, (Natural, MText)))) - [aesonQQ| - { "prim": "pair", - "args": - [ { "prim": "int" }, - { "prim": "pair", "args": [ { "prim": "nat" }, { "prim": "string" } ] } ] } - |] - - ] - , testGroup "Contract" - [ testCase "Conversion of contract with duplicated 'storage' block fails" $ do - fromExpressionFailWithPredicateTest @U.Contract - (T.isInfixOf "Something's wrong with top-level contract blocks") - [aesonQQ| - [ { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "parameter", "args": [ { "prim": "unit" } ] }, - { "prim": "storage", "args": [ { "prim": "unit" } ] } ] - |] - , testCase "Conversion of contract with absence one of blocks fails" $ do - fromExpressionFailWithPredicateTest @U.Contract - (T.isInfixOf "Something's wrong with top-level contract blocks") - [aesonQQ| - [ { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, { "prim": "UNIT" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] - |] - , testCase "Conversion of contract with invalid block arguments count fails" $ do - fromExpressionFailWithPredicateTest @U.Contract - (T.isInfixOf "Expected 'storage' block without annotations and exactly 1 argument") - [aesonQQ| - [ { "prim": "storage", - "args": [ { "prim": "unit"}, {"prim": "int"} ] }, - { "prim": "parameter", "args": [ { "prim": "unit" } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, { "prim": "UNIT" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] - |] - , testCase "Conversion of contract with error inside block fails" $ do - fromExpressionFailWithPredicateTest @U.Contract - (T.isInfixOf "Expected a type") - [aesonQQ| - [ { "prim": "storage", - "args": [ { "prim": "unit", "args": [ { "prim": "int" } ] } ] }, - { "prim": "parameter", "args": [ { "prim": "unit" } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, { "prim": "UNIT" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] - |] - , testCase "Conversion of contract with parameter which contains more than 1 root ann" $ do - fromExpressionFailWithPredicateTest @U.Contract - (T.isInfixOf "Expected parameter with at most 1 root annotation") - [aesonQQ| - [ { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "parameter", - "args": [ { "prim": "unit", "annots": [ "%root1", "%root2" ] } ]}, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, { "prim": "UNIT" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] - |] - ] - , testGroup "Annotations" - [ testGroup "Instructions" - [ testCase "Conversion of instruction with extra annotations fails" $ do - fromExpressionFailTest @U.ExpandedInstr - [aesonQQ| - { "prim": "PAIR", - "annots": [ ":ta", "@va1", "@va2", "%fa1", "%fa2", "%fa3" ] } - |] - , testCase "Conversion of instruction with annotation of unexpected type fails" $ do - fromExpressionFailTest @U.ExpandedInstr - [aesonQQ| - { "prim": "DUP", - "annots": [ "@va", "%fa" ] } - |] - ] - - , testGroup "Types" - [ testCase "Conversion of type with extra annotations fails" $ do - fromExpressionFailTest @U.Ty - [aesonQQ| { "prim": "int", "annots": [ ":ta", "%fa" ] } |] - ] - ] - ] - where - fromExpressionTest :: forall t. (Eq t, Show t, M.FromExpression t) => t -> Value -> Assertion - fromExpressionTest expected exprJSON = - case fromJSON @M.Expression exprJSON of - Error err -> assertFailure err - Success expr -> do - actual <- either (assertFailure . displayException) pure $ M.fromExpression @t expr - actual @?= expected - - fromExpressionFailTest :: forall t. (M.FromExpression t) => Value -> Assertion - fromExpressionFailTest = fromExpressionFailWithPredicateTest @t (const True) - - fromExpressionFailWithPredicateTest - :: forall t. - (HasCallStack, M.FromExpression t) - => (Text -> Bool) - -> Value - -> Assertion - fromExpressionFailWithPredicateTest p exprJSON = - case fromJSON @M.Expression exprJSON of - Error err -> assertFailure err - Success expr -> case M.fromExpression @t expr of - Right _ -> assertFailure "Test was expected to fail, but it passed" - Left (M.FromExpressionError _ msg) -> - unless (p msg) $ - assertFailure $ "Test failed with an unexpected error type:\n " <> toString msg - -test_toExpression :: [TestTree] -test_toExpression = - [ testCase "Converting TInt to Expression" $ - M.toExpression T.TInt `shouldBe` - M.ExpressionPrim (M.MichelinePrimAp (M.MichelinePrimitive "int") [] []) - - , testCase "Converting (TOption TString) to Expression" $ - M.toExpression (T.TOption T.TString) `shouldBe` - M.ExpressionPrim - ( M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "option" - , mpaArgs = [M.ExpressionPrim - ( M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "string" - , mpaArgs = [], mpaAnnots = [] } - )] - , mpaAnnots = [] - } - ) - - , testCase "Converting Instr (DIP SIZE) to Expression" $ - M.toExpression (T.DIP (T.SIZE @'T.TString)) `shouldBe` - M.ExpressionSeq - [ M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "DIP" - , mpaArgs = [M.ExpressionSeq [M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "SIZE" - , mpaArgs = [] - , mpaAnnots = [] - })]] - , mpaAnnots = [] - })] - , testCase "Converting VInt to Expression" $ - M.toExpression @(T.Value $ T.ToT Integer) (T.VInt 12) `shouldBe` M.ExpressionInt 12 - - , testCase "Converting VPair to Expression" $ - M.toExpression @(T.Value $ T.ToT (Integer, Integer)) - (T.VPair (T.VInt 12, T.VInt 12)) `shouldBe` - M.ExpressionSeq [M.ExpressionInt 12, M.ExpressionInt 12] - - , testCase "Converting VOption (Some) to Expression" $ - M.toExpression @(T.Value $ T.ToT (Maybe Integer)) (T.VOption $ Just $ T.VInt 42) `shouldBe` - M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Some" - , mpaArgs = [M.ExpressionInt 42] - , mpaAnnots = [] - }) - - , testCase "Converting VOption (None) to Expression" $ - M.toExpression @(T.Value $ T.ToT (Maybe Integer)) (T.VOption Nothing) `shouldBe` - M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "None" - , mpaArgs = [] - , mpaAnnots = [] - }) - - , testCase "Converting VList to Expression" $ - M.toExpression @(T.Value $ T.ToT [Integer]) (T.VList [T.VInt 12, T.VInt 12]) `shouldBe` - M.ExpressionSeq [M.ExpressionInt 12, M.ExpressionInt 12] - - , testCase "Converting VMap to Expression" $ - M.toExpression @(T.Value $ T.ToT (Map Integer Integer)) - (T.VMap (Map.fromList [(T.VInt 12, T.VInt 12), (T.VInt 13, T.VInt 13)])) `shouldBe` - M.ExpressionSeq - [ (M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Elt" - , mpaArgs = [M.ExpressionInt 12, M.ExpressionInt 12] - , mpaAnnots = [] - } - ) - , (M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Elt" - , mpaArgs = [M.ExpressionInt 13, M.ExpressionInt 13] - , mpaAnnots = [] - } - ) - ] - - , testCase "Converting VOr (Right) to Expression" $ - M.toExpression @(T.Value $ T.ToT (Either Integer Integer)) (T.VOr $ Right $ T.VInt 12) `shouldBe` - M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Right" - , mpaArgs = [M.ExpressionInt 12] - , mpaAnnots = [] - } - - , testCase "Converting VOr (Left) to Expression" $ - M.toExpression @(T.Value $ T.ToT (Either Integer Integer)) (T.VOr $ Left $ T.VInt 12) `shouldBe` - M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Left" - , mpaArgs = [M.ExpressionInt 12] - , mpaAnnots = [] - } - - , testCase "Converting VSet to Expression" $ - M.toExpression @(T.Value $ T.ToT (Set Integer)) (T.VSet $ Set.fromList [T.VInt 1, T.VInt 2]) `shouldBe` - M.ExpressionSeq [M.ExpressionInt 1, M.ExpressionInt 2] - - , testCase "Converting VMutez to Expression" $ - M.toExpression @(T.Value $ T.ToT Mutez) (T.VMutez $ 12) `shouldBe` - M.ExpressionInt 12 - - , testCase "Converting VBool to Expression" $ - M.toExpression @(T.Value $ T.ToT Bool) (T.VBool True) `shouldBe` - M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "True" - , mpaArgs = [] - , mpaAnnots = [] - }) - - , testCase "Converting VContract to Expression" $ - M.toExpression @(T.Value $ 'T.TContract 'T.TAddress) - (getSampleValue @('T.TContract 'T.TAddress)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") - - , testCase "Converting VBigMap to Expression" $ - M.toExpression @(T.Value $ 'T.TBigMap (T.ToT Integer) (T.ToT Integer)) - (T.VBigMap Nothing $ Map.fromList [(T.VInt 1, T.VInt 2), (T.VInt 3, T.VInt 4)]) `shouldBe` - M.ExpressionSeq - [ (M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Elt" - , mpaArgs = [M.ExpressionInt 1, M.ExpressionInt 2] - , mpaAnnots = [] - } - ) - , (M.ExpressionPrim - M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Elt" - , mpaArgs = [M.ExpressionInt 3, M.ExpressionInt 4] - , mpaAnnots = [] - } - ) - ] - - , testCase "Converting VUnit to Expression" $ - M.toExpression @(T.Value 'T.TUnit) T.VUnit `shouldBe` - M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Unit" - , mpaArgs = [] - , mpaAnnots = [] - }) - - , testCase "Converting VKey to Expression" $ - M.toExpression @(T.Value 'T.TKey) (getSampleValue @('T.TKey)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082") - - , testCase "Converting VTimestamp to Expression" $ - M.toExpression @(T.Value 'T.TTimestamp) (getSampleValue @('T.TTimestamp)) `shouldBe` - M.ExpressionInt 1564142952 - - , testCase "Converting VAddress to Expression" $ - M.toExpression @(T.Value 'T.TAddress) (getSampleValue @('T.TAddress)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200") - - , testCase "Converting VChainId to Expression" $ - M.toExpression @(T.Value 'T.TChainId) (getSampleValue @('T.TChainId)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "458aa837") - - , testCase "Converting VSignature to Expression" $ - M.toExpression @(T.Value 'T.TSignature) (getSampleValue @('T.TSignature)) `shouldBe` - (M.ExpressionBytes $ unsafe $ fromHex - "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd89\ - \1cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201") - - , testCase "Converting VKeyHash to Expression" $ - M.toExpression @(T.Value 'T.TKeyHash) (getSampleValue @('T.TKeyHash)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d") - - , testCase "Converting VBls12381Fr to Expression" $ - M.toExpression @(T.Value 'T.TBls12381Fr) (getSampleValue @('T.TBls12381Fr)) `shouldBe` - M.ExpressionBytes (unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000") - - , testCase "Converting VLam to Expression" $ - M.toExpression @(T.Value $ 'T.TLambda 'T.TUnit 'T.TUnit) - (getSampleValue @('T.TLambda 'T.TUnit 'T.TUnit)) `shouldBe` - M.ExpressionSeq - [ M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "DROP" - , mpaArgs = [] - , mpaAnnots = [] - } - ) - , M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "PUSH" - , mpaArgs = - [ M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "unit" - , mpaArgs = [] - , mpaAnnots = [] - }) - , M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "Unit" - , mpaArgs = [] - , mpaAnnots = [] - }) - ] - , mpaAnnots = [] - }) - ] - - , testCase "Converting NTPair to Expression" $ - M.toExpression [notes|pair :pair (string %a) (int %b :val)|] `shouldBe` - M.ExpressionPrim - (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "pair" - , mpaArgs = - [ M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "string" - , mpaArgs = [] - , mpaAnnots = [M.AnnotationField "a"] - }) - , M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "int" - , mpaArgs = [] - , mpaAnnots = [ M.AnnotationType "val", M.AnnotationField "b"] - }) - ] - , mpaAnnots = [ M.AnnotationType "pair" ] - } - ) - - , testCase "Converting \"CAR @bar %foo\" to Expression" $ - M.toExpression (T.AnnCAR "bar" "foo") `shouldBe` - M.ExpressionSeq - [ M.ExpressionPrim $ M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "CAR" - , mpaArgs = [] - , mpaAnnots = - [ M.AnnotationField "foo" - , M.AnnotationVariable "bar" - ] - } - ] - - , testCase "Converting sample contract to Expression" $ - M.toExpression sampleContract `shouldBe` - M.ExpressionSeq - [ M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "storage" - , mpaArgs = [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "chain_id", mpaArgs = [], mpaAnnots = []})] - , mpaAnnots = [] - }) - , M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "parameter" - , mpaArgs = [M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "unit", mpaArgs = [], mpaAnnots = []})] - , mpaAnnots = [] - }) - , M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "code" - , mpaArgs = [M.ExpressionSeq - [ M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "DROP", mpaArgs = [], mpaAnnots = []}) - , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "CHAIN_ID", mpaArgs = [], mpaAnnots = []}) - , M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "NIL" - , mpaArgs = - [ M.ExpressionPrim (M.MichelinePrimAp - { mpaPrim = M.MichelinePrimitive "operation" - , mpaArgs = [] - , mpaAnnots = [] - }) - ] - , mpaAnnots = [] - }) - , M.ExpressionPrim (M.MichelinePrimAp {mpaPrim = M.MichelinePrimitive "PAIR", mpaArgs = [], mpaAnnots = []}) - ]] - , mpaAnnots = [] - }) - ] - ] - where - sampleContract :: T.Contract 'T.TUnit 'T.TChainId - sampleContract = - let code = T.DROP `T.Seq` T.CHAIN_ID `T.Seq` T.NIL `T.Seq` T.PAIR - in T.Contract - { cCode = code - , cParamNotes = T.starParamNotes @'T.TUnit - , cStoreNotes = T.starNotes - , cEntriesOrder = U.SPC - , cViews = def - } - - getSampleValue :: forall t. (T.SingI t) => T.Value t - getSampleValue = Unsafe.fromJust $ T.sampleTypedValue $ T.sing @t diff --git a/morley-test/Test/OpSize.hs b/morley-test/Test/OpSize.hs deleted file mode 100644 --- a/morley-test/Test/OpSize.hs +++ /dev/null @@ -1,277 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for operation size evaluation. - -module Test.OpSize - ( test_Nesting - , test_Numbers - , test_Values - , test_Types - , test_Instructions - ) where - -import Prelude hiding (EQ) - -import Data.Text qualified as T -import Fmt (pretty) -import Hedgehog (Gen) -import Test.HUnit (Assertion, (@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Tezos.Address (genAddress) -import Hedgehog.Gen.Tezos.Crypto (genKeyHash) -import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519 -import Hedgehog.Gen.Tezos.Crypto.Secp256k1 qualified as Secp256k1 -import Morley.Michelson.Macro -import Morley.Michelson.Parser qualified as Parser -import Morley.Michelson.Typed -import Morley.Michelson.Untyped (buildEpName) -import Morley.Michelson.Untyped.OpSize -import Morley.Tezos.Core -import Morley.Tezos.Crypto -import Morley.Util.Text (dquotes) -import Test.Cleveland.Util (runGen) - -import Test.Util.Parser - -(?==) :: HasCallStack => Text -> Word -> Assertion -codeText ?== expectedCost = do - parsed <- Parser.codeEntry `shouldParse` ("{" <> codeText <> "}") - let code = expandList parsed - expandedInstrsOpSize code @?= OpSize expectedCost - -{- All particular numbers below are got using dump-op-size.py script -} - -test_Nesting :: [TestTree] -test_Nesting = - [ testCase "empty string" $ "" ?== 0 - , testCase "{}" $ "{}" ?== 5 - , testCase "{}; {}" $ "{}; {}" ?== 10 - , testCase "100 * {}" $ mconcat (replicate 100 "{}; ") ?== 500 - , testCase "{{}}" $ "{{}}" ?== 10 - ] - -test_Numbers :: [TestTree] -test_Numbers = - [ numTestCase 0 8 - , numTestCase 1 8 - , numTestCase 2 8 - , numTestCase 63 8 - , numTestCase 64 9 - , numTestCase 65 9 - , numTestCase 2048 9 - , numTestCase 20480 10 - , numTestCase (-1) 8 - , numTestCase (-63) 8 - , numTestCase (-64) 9 - ] - where - numTestCase (n :: Int) gas = - testCase (show n) $ ("PUSH int " <> show n <> "; DROP") ?== gas - -test_Values :: [TestTree] -test_Values = - [ testGroup "int" - [ valueTestCaseExt "small" "int" "5" 8 - , valueTestCaseExt "bigger" "int" "63" 8 - , valueTestCaseExt "big" "int" "64" 9 - ] - , valueTestCase "nat" "5" 8 - , testGroup "string" - [ stringTestCase 0 11 - , stringTestCase 1 12 - , stringTestCase 2 13 - , stringTestCase 7 18 - , stringTestCase 8 19 - ] - , testGroup "bytes" - [ bytesTestCase 0 11 - , bytesTestCase 1 12 - , bytesTestCase 2 13 - , bytesTestCase 7 18 - , bytesTestCase 8 19 - ] - , valueTestCase "mutez" "5" 8 - , valueTestCase "bool" "True" 8 - , valueTestCase "key_hash" (dquotes $ pretty (gen genKeyHash)) 47 - , testGroup "timestamp" - [ valueTestCaseExt "small" "timestamp" "5" 8 - , valueTestCaseExt "bigger" "timestamp" "123" 9 - , valueTestCaseExt "textual" "timestamp" (dquotes "2018-08-08 00:00:00Z") 31 - ] - , testGroup "address" - [ valueTestCaseExt "plain tz address" "address" (dquotes $ pretty (gen genAddress)) 47 - , 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) . unsafe $ buildEpName "a" - in valueTestCaseExt "short entrypoint" "address" (dquotes $ pretty epAddr) 49 - , 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 - , valueTestCase "key" (dquotes $ pretty (PublicKeyEd25519 (gen Ed25519.genPublicKey))) 65 - , valueTestCase "key" (dquotes $ pretty (PublicKeySecp256k1 (gen Secp256k1.genPublicKey))) 66 - , valueTestCase "unit" "Unit" 8 - , valueTestCase "signature" (dquotes $ pretty (SignatureEd25519 (gen Ed25519.genSignature))) 110 - , testGroup "chain_id" - [ valueTestCase "chain_id" (dquotes $ pretty dummyChainId) 26 - , valueTestCase "chain_id" "0x00000000" 15 - ] - , testGroup "option" - [ valueTestCaseExt "none" "(option int)" "None" 10 - , valueTestCaseExt "some" "(option int)" "(Some 5)" 12 - ] - , testGroup "list" - [ valueTestCaseExt "Empty" "(list int)" "{}" 13 - , valueTestCaseExt "Length 1" "(list int)" "{1}" 15 - , valueTestCaseExt "Length 8" "(list int)" "{1;1;1;1;1;1;1;1}" 29 - ] - , testGroup "set" - [ valueTestCaseExt "Empty" "(set int)" "{}" 13 - , valueTestCaseExt "Length 1" "(set int)" "{1}" 15 - , valueTestCaseExt "Length 1" "(set int)" "{1;2;3;4;5;6;7;8}" 29 - ] - , valueTestCaseExt "pair" "(pair int int)" "(Pair 1 2)" 16 - , valueTestCaseExt "or" "(or int int)" "(Left 1)" 14 - , testGroup "lambda" - [ valueTestCaseExt "empty lambda" "(lambda int int)" "{}" 15 - , valueTestCaseExt "simple lambda" "(lambda int int)" "{DUP; DROP}" 19 - ] - , testGroup "map" - [ valueTestCaseExt "Empty" "(map int int)" "{}" 15 - , valueTestCaseExt "Length 1" "(map int int)" "{Elt 1 2}" 21 - , valueTestCaseExt "Length 1 (big key)" "(map int int)" "{Elt 100 2}" 22 - , let val = "{Elt 1 1; Elt 2 2; Elt 3 3; Elt 4 4; \ - \ Elt 5 5; Elt 6 6; Elt 7 7; Elt 8 8 }" - in valueTestCaseExt "Length 8" "(map int int)" val 63 - ] - ] - where - valueTestCaseExt name ty val gas = - testCase name $ - ("PUSH " <> ty <> " " <> val <> "; DROP") ?== gas - valueTestCase ty val gas = - valueTestCaseExt (toString ty) ty val gas - stringTestCase l gas = - let name = "Length " <> show l - val = dquotes $ T.replicate l "a" - in valueTestCaseExt name "string" val gas - bytesTestCase l gas = - let name = "Length " <> show l - val = "0x" <> T.replicate l "12" - in valueTestCaseExt name "bytes" val gas - - gen :: Gen a -> a - gen genA = runGen 20 12 genA - -test_Types :: [TestTree] -test_Types = - [ typeTestCase "int" 8 - , typeTestCase "string" 8 - , typeTestCase "mutez" 8 - , typeTestCase "key_hash" 8 - , typeTestCase "address" 8 - , typeTestCase "signature" 8 - , typeTestCase "option int" 10 - , typeTestCase "list int" 10 - , typeTestCase "set int" 10 - , typeTestCase "contract int" 10 - , typeTestCase "pair int int" 12 - , typeTestCase "or int int" 12 - , typeTestCase "or (pair nat nat) (pair int nat)" 20 - , typeTestCase "lambda int unit" 12 - , typeTestCase "map int int" 12 - , typeTestCase "big_map int int" 12 - , typeTestCase "lambda operation int" 12 - - , typeTestCase "pair int int" 12 - , typeTestCase "pair (int : %) int" 12 - , typeTestCase "pair (int :a) int" 18 - , typeTestCase "pair (int %a) int" 18 - , typeTestCase "pair (int %a :a) int" 21 - , typeTestCase "pair (int %a) (int %a)" 24 - , typeTestCase "pair :a (int %a) (int %a)" 30 - , typeTestCase "pair :a int (int %a)" 24 - , typeTestCase "pair : (int %a :) (int %a)" 24 - , typeTestCase "pair :a (int %a :a) (int %a)" 33 - ] - where - typeTestCase t gas = - testCase (toString t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas - -test_Instructions :: [TestTree] -test_Instructions = - [ instrTestCase "FAILWITH" 2 - , instrTestCase "FAIL" 9 - - , instrTestCaseFailWith "DUP" 4 - , instrTestCaseFailWith "DUP @" 4 - , instrTestCaseFailWith "DUP @a" 10 - , instrTestCaseFailWith "DUP; DROP" 6 - , instrTestCaseFailWith "DUP; SWAP" 6 - , instrTestCaseFailWith "DUP; SWAP; SWAP" 8 - , instrTestCaseFailWith "PUSH int 0" 8 - , instrTestCaseFailWith "PUSH @a int 0" 14 - , instrTestCaseFailWith "PUSH @a (int :a) 0" 20 - , instrTestCaseFailWith "SOME" 4 - , instrTestCaseFailWith "SOME @" 4 - , instrTestCaseFailWith "SOME @a" 10 - , instrTestCaseFailWith "NONE int" 6 - , instrTestCaseFailWith "NONE (option int)" 8 - , instrTestCaseFailWith "NONE :a @a (option :a int)" 23 - , instrTestCaseFailWith "UNIT" 4 - , instrTestCaseFailWith "DUP; SOME; IF_NONE {}{DROP}" 20 - , instrTestCaseFailWith "DUP; DUP; PAIR" 8 - , instrTestCaseFailWith "DUP; DUP; PAIR % % : @" 8 - , instrTestCaseFailWith "DUP; DUP; PAIR %a" 14 - , instrTestCaseFailWith "DUP; DUP; PAIR %a %a" 17 - , instrTestCaseFailWith "DUP; DUP; PAIR %a %a :a" 20 - , instrTestCaseFailWith "DUP; DUP; PAIR %a % :a @a" 20 - , instrTestCaseFailWith "DUP; DUP; PAIR % %a :a @a" 23 - , instrTestCaseFailWith "DUP; DUP; PAIR %a %a :a @a" 23 - -- Further skipping some instructions since everything is trivial - , instrTestCaseFailWith "EMPTY_BIG_MAP :a @a (int :a) (unit :a)" 29 - , instrTestCaseFailWith "PUSH (list int) {}; MAP {}" 20 - , instrTestCaseFailWith "DIP {}" 9 - , instrTestCaseFailWith "DIP 0 {}" 11 - , instrTestCaseFailWith "DIP 1 {}" 11 - , instrTestCaseFailWith "DROP 0" 6 - , instrTestCaseFailWith "PACK" 4 - , instrTestCaseFailWith "PUSH int 1; PUSH int 2; ADD" 16 - , instrTestCaseFailWith "DUP; CONTRACT int" 8 - - , namedInstrTestCaseFailWith "CREATE_CONTRACT" - "UNIT; PUSH mutez 5; NONE key_hash; \ - \CREATE_CONTRACT \ - \{ parameter unit; \ - \ storage unit; \ - \ code { CDR; NIL operation; PAIR } }" 44 - - , namedInstrTestCaseFailWith "CREATE_CONTRACT + PUSH or" - "PUSH (or int nat) (Left 5); PUSH mutez 5; NONE key_hash; \ - \CREATE_CONTRACT \ - \{ parameter unit; \ - \ storage (or int nat); \ - \ code { DROP; PUSH (or int nat) (Right 2); NIL operation; PAIR } }" 70 - , namedInstrTestCaseFailWith "CREATE_CONTRACT + PUSH or + Annotation" - "PUSH (or %root int nat) (Left 5); PUSH mutez 5; NONE key_hash; \ - \CREATE_CONTRACT \ - \{ parameter unit; \ - \ storage (or int nat); \ - \ code { DROP; PUSH (or int nat) (Right 2); NIL operation; PAIR } }" 70 - ] - where - namedInstrTestCase testName instr gas = - testCase testName $ instr ?== gas - - namedInstrTestCaseFailWith testName instr gas = - namedInstrTestCase testName (instr <> "; FAILWITH") gas - - instrTestCase 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 deleted file mode 100644 --- a/morley-test/Test/Optimizer.hs +++ /dev/null @@ -1,277 +0,0 @@ --- 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 - ( unit_Optimize_Nop - , unit_Optimize_DROP_n - , unit_Optimize_DIP_n - , unit_Redundant_DIP - , unit_Adjacent_DIPs - , unit_Adjacent_DROPs - , unit_Nested_adjacent_DIPs - , unit_UNPAIR_DROP - , unit_Specific_PUSH - , unit_Optimize_PUSH_PACK - , unit_Optimizer_Tree_Independence - , unit_Sample_optimize - , unit_Pair_Unpair - , unit_Optimize_PAIR_CADR - , unit_Optimize_following_DROPs - , unit_Optimize_following_DROPs_double - , unit_Optimize_multiple_following_DROPs - , unit_Optimize_branch_shortcuts_with_PUSH - - , unit_golden - ) where - -import Prelude hiding (EQ) - -import Data.Default (def) -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 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.Util.Contracts -import Test.Util.HUnit - - --- Sample stacks of length 0, 1… -type Stack0 = '[ ] -type Stack1 = '[ 'T.TUnit ] -type Stack1Int = '[ 'T.TInt ] -type Stack1Pair = '[ 'T.TPair 'T.TUnit 'T.TUnit ] -type Stack2 = '[ 'T.TUnit, 'T.TUnit ] -type Stack2UnitInt = '[ 'T.TUnit, 'T.TInt ] - -unit_Optimizer_Tree_Independence :: Assertion -unit_Optimizer_Tree_Independence = do - optimize @Stack1Pair @Stack1 (DUP `Seq` (CAR `Seq` (DIP CDR `Seq` DROP))) @?= CDR - optimize @Stack1Pair @Stack1 ((DUP `Seq` CAR) `Seq` (DIP CDR `Seq` DROP)) @?= CDR - optimize @Stack1Pair @Stack1 (((DUP `Seq` CAR) `Seq` DIP CDR) `Seq` DROP) @?= CDR - optimize ( - PUSH (T.VBool True) `Seq` - IF (PUSH (T.VOption $ Just strValue)) (PUSH (T.VOption Nothing)) `Seq` - IF_NONE (PUSH (T.VBool False)) (DROP `Seq` PUSH (T.VBool True)) - `Seq` DROP) @?= Nop - optimize ( - PUSH (T.VBool True) :# - IF (PUSH (T.VOption $ Just strValue)) (PUSH (T.VOption Nothing)) :# - IF_NONE (PUSH (T.VBool False)) (DROP :# PUSH (T.VBool True)) :# - DROP) @?= Nop - -unit_Optimize_Nop :: Assertion -unit_Optimize_Nop = do - -- NOTE: at the moment of writing this test does not actually test anything - -- because our 'Eq' on typed 'Instr' is not strict, it compares via casting - -- the instruction to untyped representation. To be resolved in #108. - optimize @Stack1Int @Stack1Int (Nop `Seq` DUP `Seq` Nop `Seq` ADD `Seq` Nop) @?= DUP `Seq` ADD - -unit_Optimize_DROP_n :: Assertion -unit_Optimize_DROP_n = do - optimize @Stack0 @Stack0 (DROPN Zero) @?= Nop - -- Sadly it is not optimized (yet). - optimize @Stack1 @Stack0 (DROPN One) @?= DROPN One - -unit_Optimize_DIP_n :: Assertion -unit_Optimize_DIP_n = do - optimize @Stack1 @Stack0 (DIPN Zero DROP) @?= DROP - -- Sadly it is not optimized (yet). - optimize @Stack1 @Stack2 (DIPN (Succ Zero) UNIT) @?= (DIPN (Succ Zero) UNIT) - -unit_Redundant_DIP :: Assertion -unit_Redundant_DIP = do - optimize @Stack1Int @Stack1 (DIP UNIT `Seq` DROP) @?= (DROP `Seq` UNIT) - optimize @Stack1Int @Stack2UnitInt (UNIT `Seq` DIP (DUP `Seq` MUL)) @?= (DUP `Seq` MUL `Seq` UNIT) - -unit_Adjacent_DIPs :: Assertion -unit_Adjacent_DIPs = do - optimize (DIP (PUSH strValue) `Seq` DIP (PUSH strValue)) @?= (DIP (PUSH strValue `Seq` PUSH strValue)) - optimize - (DIP (PUSH strValue) `Seq` - DIP UNIT `Seq` - DIP PAIR) - @?= (DIP (PUSH strValue `Seq` UNIT `Seq` PAIR)) - -unit_Adjacent_DROPs :: Assertion -unit_Adjacent_DROPs = do - optimize (DROP `Seq` DROP) @?= - DROPN Two - optimize (UNIT `Seq` DROP `Seq` DROP `Seq` DROP `Seq` NOW) @?= - (DROPN Two `Seq` NOW) - -- TODO #299: We don't optimize more than 2 DROPs in a row yet :( - -- optimize (DROP `Seq` DROP `Seq` DROP `Seq` UNIT) @?= - -- (DROPN (Succ Two) `Seq` UNIT) - -unit_Nested_adjacent_DIPs :: Assertion -unit_Nested_adjacent_DIPs = do - optimize - (IF_NONE (PUSH strValue) (DIP (PUSH strValue) `Seq` DIP (PUSH strValue) `Seq` DIP CONCAT `Seq` CONCAT)) - @?= (IF_NONE (PUSH strValue) (DIP (PUSH strValue `Seq` PUSH strValue `Seq` CONCAT) `Seq` CONCAT)) - -unit_UNPAIR_DROP :: Assertion -unit_UNPAIR_DROP = do - optimize @Stack1Pair @Stack2 (DUP :# CAR :# DIP CDR) @?= UNPAIR - optimize @Stack1Pair @Stack1 (((DUP :# CAR) :# DIP CDR) :# DROP) @?= CDR - optimize @Stack1Pair @Stack1 (DUP :# CAR :# DIP CDR :# DROP) @?= CDR - -unit_Specific_PUSH :: Assertion -unit_Specific_PUSH = do - optimize (PUSH (T.VMap @'T.TInt @'T.TUnit mempty)) @?= EMPTY_MAP - optimize (PUSH (T.VSet @'T.TInt mempty) `Seq` NOW) @?= (EMPTY_SET `Seq` NOW) - optimize (PUSH T.VUnit) @?= UNIT - -unit_Optimize_PUSH_PACK :: Assertion -unit_Optimize_PUSH_PACK = - optimize' - (PUSH strValue `Seq` PACK `Seq` DUP) @?= - (PUSH (T.VBytes $ packValue' strValue) `Seq` DUP) - where - optimize' = - optimizeWithConf @Stack0 @'[ 'T.TBytes, 'T.TBytes ] - (def {ocRuleset = defaultRulesAndPushPack}) - -unit_Sample_optimize :: Assertion -unit_Sample_optimize = optimize nonOptimal @?= expectedOptimized - -unit_Pair_Unpair :: Assertion -unit_Pair_Unpair = - optimize - (PAIR `Seq` UNPAIR `Seq` UNPAIR `Seq` PAIR) @?= - Nop - -unit_Optimize_PAIR_CADR :: Assertion -unit_Optimize_PAIR_CADR = do - optimize (PAIR `Seq` CDR) @?= DROP - optimize (PAIR `Seq` CAR) @?= (SWAP `Seq` DROP) - -unit_Optimize_following_DROPs :: Assertion -unit_Optimize_following_DROPs = do - optimize (PUSH strValue `Seq` SIZE @'T.TString `Seq` INT `Seq` DROP) @?= Nop - optimize (PUSH intValue `Seq` NEG `Seq` ABS `Seq` DROP) @?= Nop - optimize (PUSH strValue `Seq` PACK `Seq` UNPACK @'T.TString `Seq` DROP) @?= Nop - optimize (PUSH (T.VPair (strValue, strValue)) `Seq` GETN (Succ Zero) `Seq` DROP) @?= Nop - optimize (SELF_ADDRESS `Seq` (CONTRACT (T.NTUnit noAnn) T.DefEpName) `Seq` DROP) @?= Nop - optimize (SELF (T.sepcPrimitive @'T.TUnit) `Seq` ADDRESS `Seq` DROP) @?= Nop - optimize (PUSH strValue `Seq` PACK `Seq` SHA256 `Seq` DROP) @?= Nop - optimize (PUSH intValue `Seq` CAST @'T.TInt `Seq` (AnnLEFT @'T.TString noAnn noAnn noAnn) `Seq` DROP) @?= Nop - -unit_Optimize_following_DROPs_double :: Assertion -unit_Optimize_following_DROPs_double = do - optimize (PUSH intValue `Seq` PUSH intValue `Seq` ADD `Seq` DROP) @?= Nop - optimize (EMPTY_MAP @'T.TInt @'T.TInt `Seq` PUSH intValue `Seq` GET `Seq` DROP) @?= Nop - optimize (UNIT `Seq` PUSH (T.VNat 1) `Seq` UNIT `Seq` TICKET `Seq` DROP `Seq` DROP) @?= Nop - optimize ( - UNIT `Seq` DUP `Seq` (AnnPAIR noAnn noAnn noAnn) `Seq` - BALANCE `Seq` AMOUNT `Seq` COMPARE `Seq` - DROP `Seq` DROP) @?= Nop - -unit_Optimize_multiple_following_DROPs :: Assertion -unit_Optimize_multiple_following_DROPs = do - optimize (PUSH strValue `Seq` PUSH strValue `Seq` DROP `Seq` DROP) @?= Nop - optimize (NOW `Seq` PUSH strValue `Seq` DUP `Seq` DROP `Seq` DROP `Seq` DROP) @?= Nop - optimize (NIL @'T.TInt `Seq` UNIT `Seq` NONE @'T.TUnit `Seq` PUSH strValue `Seq` DROP `Seq` DROP `Seq` DROP `Seq` DROP) @?= Nop - -unit_Optimize_branch_shortcuts_with_PUSH :: Assertion -unit_Optimize_branch_shortcuts_with_PUSH = do - -- TODO #300: Optimization stops after one step. - -- As a result there is (PUSH _ `Seq` PUSH _ `Seq` DROP `Seq` DROP) - -- on stack instead of Nop. - -- optimize (PUSH strValue `Seq` PUSH (T.VList $ replicate 5 intValue) `Seq` IF_CONS (DROP `Seq` DROP) Nop `Seq` DROP) @?= Nop - optimize (PUSH (T.VOr @'T.TString @'T.TUnit $ Left strValue) `Seq` IF_LEFT DROP DROP) @?= Nop - optimize (PUSH strValue `Seq` PUSH (T.VOption @'T.TUnit Nothing) `Seq` IF_NONE Nop DROP `Seq` DROP) @?= Nop - -str :: MText -str = "aa" - -strValue :: T.Value 'T.TString -strValue = T.VString str - -intValue :: T.Value 'T.TInt -intValue = T.VInt 1 - -nonOptimal :: T.ContractCode 'T.TString 'T.TString -nonOptimal = - CAR `Seq` - -- `PUSH; DROP` is erased - -- We also arbitrarily group two instructions here to make - -- structure definitely non-linear. - (PUSH strValue `Seq` SWAP `Seq` SWAP `Seq` DROP) `Seq` - -- If we PUSH and then DIP, DIP is not necessary - PUSH strValue `Seq` - -- `DUP; DROP` is also erased - DIP (DUP `Seq` DUP `Seq` DROP) `Seq` - -- `SWAP; SWAP` is erased, along with surrounding redundant instructions and outer `DIP` - DIP (PUSH (T.VBool False) `Seq` IF (Nop) (SWAP `Seq` SWAP)) `Seq` - CONCAT `Seq` - Nested (SIZE `Seq` - -- `COMPARE` with 0 is redundant - (PUSH (T.VNat 0) `Seq` COMPARE) `Seq` EQ `Seq` - -- Here both bodys of `IF` can be erased and then `IF` can be replaced with `DROP` - IF (DUP `Seq` DROP) (UNIT `Seq` DROP) `Seq` - -- `LEFT` followed by `IF_LEFT` can be optimized - (AnnLEFT @('T.TKey) noAnn noAnn noAnn) `Seq` - IF_LEFT Nop (UNIT `Seq` FAILWITH) `Seq` - -- SWAP is redundant after DUP - DUP `Seq` SWAP `Seq` CONCAT `Seq` - -- `DIP Nop` is thrown away - DIP (UNIT `Seq` DROP) `Seq` - -- Finish, nothing to optimize here - NIL `Seq` PAIR) - --- Auxiliary operator to produce right linear sequence. We do not use --- it above because input instruction can have arbitrary structure, --- but we know that the output is right balanced. In practice we can't --- check it though, because that's how our 'Eq' is defined. -(#<#) :: T.Instr a b -> T.Instr b c -> T.Instr a c -(#<#) = Seq -infixr 1 #<# - --- Expected output of the optimizer. -expectedOptimized :: T.ContractCode 'T.TString 'T.TString -expectedOptimized = - CAR #<# - DUP #<# CONCAT #<# - NIL #<# PAIR - --- [TODO] After introduction of WithLoc the test below started to fail. --- Probably the cause is the same as in #300. As a temporary measure we drop --- all 'WithLoc' before making optimizations. -dropWithLoc :: T.Instr i o -> T.Instr i o -dropWithLoc = T.dfsModifyInstr def $ \case - T.WithLoc _ i -> i - i -> i - -unit_golden :: Assertion -unit_golden = do - contracts <- getContractsWithReferences ".mtz" (inContractsDir "optimizer") "opt" - mapM_ optimizerTest contracts - where - optimizerTest :: (FilePath, FilePath) -> Assertion - optimizerTest (srcPath, optPath) = do - someContract <- importUsing readSomeContractExt srcPath - let - optimized :: T.SomeContract - optimized = mapSomeContract (optimize . dropWithLoc) someContract - - expectedOptimizedTxt <- strip . fromStrict <$> Utf8.readFile optPath - assertEqualBuild - ("Optimizing " <> srcPath <> " does not match the expected format") - expectedOptimizedTxt - (printSomeContract False optimized) diff --git a/morley-test/Test/Parser.hs b/morley-test/Test/Parser.hs deleted file mode 100644 --- a/morley-test/Test/Parser.hs +++ /dev/null @@ -1,601 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Test.Parser - ( test_parse_contracts - , test_value - , test_string_literal - , test_annotation - , test_IF - , test_MAP - , test_PAIR - , test_UNPAIR - , test_pair_type - , test_tuple_type - , test_or_type - , test_lambda_type - , test_list_type - , test_set_type - , test_Pair_constructor - , test_printComment - , test_parser_exception - , test_letType - , test_block_comment - , test_UNPAPAIR - , test_mandatory_spaces - ) where - -import Data.List.NonEmpty qualified as NE -import Data.Text.IO.Utf8 qualified as Utf8 (readFile) -import Test.Hspec (shouldBe, shouldSatisfy) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase) -import Text.Megaparsec (parse) -import Text.Megaparsec.Error - (ErrorFancy(ErrorCustom), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors) - -import Morley.Michelson.ErrorPos (srcPos) -import Morley.Michelson.Macro as Mo -import Morley.Michelson.Parser as P -import Morley.Michelson.Parser.Annotations as PA -import Morley.Michelson.Parser.Lexer as PL -import Morley.Michelson.Parser.Types (LetEnv, Parser') -import Morley.Michelson.Untyped as Mo -import Morley.Util.Positive -import Test.Cleveland.Instances () -import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts) - ----------------------------------------------------------------------------- --- Contracts ----------------------------------------------------------------------------- - -test_parse_contracts :: [TestTree] -test_parse_contracts = - [ testCase "well-typed and ill-typed contracts are parsable" $ do - files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts - mapM_ (checkFile True) files - , testCase "bad contracts are unparsable" $ do - files <- getUnparsableContracts - mapM_ (checkFile False) files - ] - ----------------------------------------------------------------------------- --- Values ----------------------------------------------------------------------------- - -test_value :: [TestTree] -test_value = testSatisfyingCases P.value - [ ( "{}" - , Right Mo.ValueNil - ) - , ( "{PUSH int 5;}" - , Right . ValueLambda $ NE.fromList - [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)] - ) - , ( "{1; 2}" - , Right . Mo.ValueSeq $ NE.fromList - [Mo.ValueInt 1, Mo.ValueInt 2] - ) - , ( "{Elt 1 2; Elt 3 4}" - , Right . Mo.ValueMap $ NE.fromList - [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)] - ) - , ( "{DIP DROP;}" - , Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| [])) - ) - , ( "{{ }; {}; {PUSH int 5; DROP}}" - , Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1) :| - [ Mo.Seq [] (srcPos 0 6) - , Mo.Seq [ Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11) - , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10) - ])) - ) - , ( "{{}; {}; {5}}" - , Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])])) - ) - ] ++ - - testSatisfyingCasesPredicate P.value - [ ("{DIP DROP;somecontent}", isLeft) - , ("{{}; {5}; {Push int 5}}", isLeft) - ] - -test_string_literal :: [TestTree] -test_string_literal = testSatisfyingCasesPredicate P.stringLiteral - [ ("\"\"", isRight) - , ("\" \\n \"", isRight) - , ("\"abacaba \\t \n\n\r a\"", isLeft) - , ("\"abacaba \\t \\n\\n\\r", isLeft) - ] - ----------------------------------------------------------------------------- --- Annotations ----------------------------------------------------------------------------- - -test_annotation :: [TestTree] -test_annotation = testSatisfyingCasesPredicate PA.noteV - [ ("@", isRight) - , ("@_", isRight) - , ("@a.", isRight) - , ("@7a", isRight) - , ("@.a", isLeft) - , ("@@@", isLeft) - , ("@a b", isLeft) - , ("@a\\", isLeft) - -- TODO [#48] these are special annotations and should not always be accepted - , ("@%", isRight) - , ("@%%", isRight) - ] - ----------------------------------------------------------------------------- --- Instructions ----------------------------------------------------------------------------- - -test_IF :: [TestTree] -test_IF = testSatisfyingCases P.codeEntry - [ ( "{IF {} {};}" - , Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)] - ) - , ( "{IFEQ {} {};}" - , Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)] - ) - , ( "{IFCMPEQ {} {};}" - , Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)] - ) - ] - -test_MAP :: [TestTree] -test_MAP = testSatisfyingCases P.codeEntry - [ ( "{MAP {};}" - , Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)] - ) - , ( "{MAP_CAR {};}" - , Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)] - ) - ] - -test_PAIR :: [TestTree] -test_PAIR = testSatisfyingCases P.codeEntry - [ ( "{PAIR;}" - , Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)] - ) - , ( "{PAIR %a;}" - , Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)] - ) - , ( "{PAIR %0;}" - , Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)] - ) - , ( "{PAPAIR;}" - , Right - [flip Mac (srcPos 0 1) $ - PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn))) - noAnn noAnn - ] - ) - ] - -test_UNPAPAIR :: [TestTree] -test_UNPAPAIR = testSatisfyingCases P.codeEntry - [ ( "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}" - , Right [unpapair] - ) - , ( "{UNPAPAIR @a %b @c %d %e @f;}" - , Right [unpapair] - ) - , ( "{UNPAPAIR;}" - , Right [unpapair] - ) - ] - where - unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1) - -test_UNPAIR :: [TestTree] -test_UNPAIR = testSatisfyingCases P.codeEntry - [ ( "{UNPAIR;}" - , Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)] - ) - , ( "{UNPAIR %a;}" - , Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)] - ) - , ( "{UNPAIR @a;}" - , Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)] - ) - , ( "{UNPAIR @a %b;}" - , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)] - ) - , ( "{UNPAIR %b @a;}" - , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)] - ) - , ( "{UNPAIR @a @b;}" - , Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)] - ) - , ( "{UNPAIR %c %d;}" - , Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)] - ) - , ( "{UNPAIR @a @b %c;}" - , Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)] - ) - , ( "{UNPAIR @a @b %c %d;}" - , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)] - ) - , ( "{UNPAIR %c %d @a;}" - , Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)] - ) - , ( "{UNPAIR %c %d @a @b;}" - , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)] - ) - ] ++ - - [ -- should fail because the two field anns are not "grouped" together. - handleTrivialError - "{UNPAIR %c @a @b %d;}" - P.codeEntry - (Tokens ('%' :| "")) - , -- should fail because the two var anns are not "grouped" together. - handleTrivialError - "{UNPAIR @a %c %d @b;}" - P.codeEntry - (Tokens ('@' :| "")) - ] - ----------------------------------------------------------------------------- --- Types ----------------------------------------------------------------------------- - -test_pair_type :: [TestTree] -test_pair_type = - [ testGroup "simple pair type" $ - testSatisfyingCases P.type_ - [ ("pair unit unit", Right unitPair) - , ("(unit, unit)", Right unitPair) - ] - ++ - testSatisfyingCasesPredicate P.type_ - [ ("(key, (int, (string, bool)))", isRight) - , ("(signature, chain_id, string, bool)", isRight) - ] - , testGroup "right-combed pair type" $ - testSatisfyingCases P.type_ - [ ("pair unit int string", Right rightCombPair) - , ("(unit, int, string)", Right rightCombPair) - ] - , testGroup "right-combed pair type with annotations" $ - testSatisfyingCases P.type_ - [ ( "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)" - , Right rightCombPairWithAnns - ) - , ( "(unit :t1 %x, int :t2 %y, string %z :t3) :t" - , Right rightCombPairWithAnns - ) - ] - ] - where - unitPair :: Mo.Ty - unitPair = - Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn - - rightCombPair :: Mo.Ty - rightCombPair = - Mo.Ty - (Mo.TPair noAnn noAnn noAnn noAnn - (Mo.Ty Mo.TUnit noAnn) - (Mo.Ty - (Mo.TPair noAnn noAnn noAnn noAnn - (Mo.Ty Mo.TInt noAnn) - (Mo.Ty Mo.TString noAnn) - ) - noAnn - ) - ) - noAnn - - rightCombPairWithAnns :: Mo.Ty - rightCombPairWithAnns = - Mo.Ty - (Mo.TPair "x" noAnn noAnn noAnn - (Mo.Ty Mo.TUnit "t1") - (Mo.Ty - (Mo.TPair "y" "z" noAnn noAnn - (Mo.Ty Mo.TInt "t2") - (Mo.Ty Mo.TString "t3") - ) - noAnn - ) - ) - "t" - -test_tuple_type :: [TestTree] -test_tuple_type = testSatisfyingCases P.type_ - [ ( "(int, int, bool, unit, nat)" - , Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat))) - ) - , ( "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))" - , Right (bigPair 16) - ) - ] - where - bigPair :: Integer -> Ty - bigPair n | n == 0 = tynat - bigPair n = typair tynat (bigPair (n - 1)) - -test_or_type :: [TestTree] -test_or_type = - testSatisfyingCases P.type_ - [ ("or unit unit", Right unitOr) - , ("(unit | unit)", Right unitOr) - ] - ++ testSatisfyingCasesPredicate P.type_ - [ ("(chain_id | (int | (string | bool)))", isRight) - , ("or unit unit kek", isLeft) - ] - where - unitOr :: Mo.Ty - unitOr = - Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn - -test_lambda_type :: [TestTree] -test_lambda_type = - satisfyingCasePredicate P.type_ "lambda int (signature, int)" isRight : - testSatisfyingCases P.type_ - [ ("lambda unit unit", Right lambdaUnitUnit) - , ("\\unit -> unit", Right lambdaUnitUnit) - ] - where - lambdaUnitUnit :: Mo.Ty - lambdaUnitUnit = - Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn - -test_list_type :: [TestTree] -test_list_type = - satisfyingCasePredicate P.type_ "[(key, key)]" isRight : - testSatisfyingCases P.type_ - [ ("list unit", Right unitList) - , ("[unit]", Right unitList) - ] - where - unitList :: Mo.Ty - unitList = - Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn - -test_set_type :: [TestTree] -test_set_type = testSatisfyingCases P.type_ - [ ("set int", Right intSet) - , ("set (pair int int)", Right intPairSet) - , ("{int}", Right intSet) - , ("{(pair int int)}", Right intPairSet) - ] - where - intSet :: Mo.Ty - intSet = - Mo.Ty (Mo.TSet (Mo.Ty Mo.TInt noAnn)) noAnn - intPairSet :: Mo.Ty - intPairSet = - Mo.Ty (Mo.TSet (Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TInt noAnn) (Mo.Ty Mo.TInt Mo.noAnn)) noAnn)) noAnn - ----------------------------------------------------------------------------- --- Constructors ----------------------------------------------------------------------------- - -test_Pair_constructor :: [TestTree] -test_Pair_constructor = - [ testGroup "simple pair constructor" $ testSatisfyingCases P.value - [ ("Pair Unit Unit", Right unitPair) - , ("(Unit, Unit)", Right unitPair) - ] - - , testGroup "right-combed pair consrtuctor" $ testSatisfyingCases P.value - [ ("Pair Unit 3 \"Hi\"", Right unitPairRightCombed) - , ("(Unit, 3, \"Hi\")", Right unitPairRightCombed) - ] - ] - where - unitPair :: Mo.Value' Mo.ParsedOp - unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit - - unitPairRightCombed :: Mo.Value' Mo.ParsedOp - unitPairRightCombed = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi")) - ----------------------------------------------------------------------------- --- Comments ----------------------------------------------------------------------------- - -test_block_comment :: [TestTree] -test_block_comment = - testSatisfyingCases PL.mSpace $ - [ "/* */" - , " /* */" - , "/* */ " - , "/* */;" - , "/* */ ;" - , "/* */\n;" - ] - `zip` repeat (Right ()) - ----------------------------------------------------------------------------- --- Delimiters ----------------------------------------------------------------------------- - -test_mandatory_spaces :: [TestTree] -test_mandatory_spaces = - [ testGroup "delimiters inside single value" $ testSatisfyingCasesPredicate P.value - [ ("Pair 1Unit", isLeft) - , ("Pair 1/*a*/2", isRight) - -- TODO [#744]: The next two cases should be both - -- either valid expressions or invalid, depending on - -- the fact what is an intended behaviour - , ("Pair\"1\"Unit", isLeft) - , ("Pair 1\"2\"", isLeft) - ] - - , testGroup "delimiters inside single instruction" $ testSatisfyingCasesPredicate P.parsedOp - -- there have to be at least one delimiter - -- between instruction items, either space or block comment - [ ("PUSHint 1", isLeft) - , ("PUSH int1", isLeft) - , ("PUSH int#a\n1", isLeft) - , ("PUSH int/*a*/1", isRight) - , ("PUSH int 1", isRight) - -- TODO [#744]: The next two cases should be both - -- either valid expressions or invalid, depending on - -- the fact what is an intended behaviour - , ("PUSH string\"1\"", isLeft) - , ("PUSH (pair string int) (Pair\"1\"2)", isLeft) - ] - - , testGroup "delimiters between instructions" $ testSatisfyingCasesPredicate P.ops - -- instructions might not be separated by @;@ - -- iff the first one is a sequence @{a; b;...} z@ - [ ("{{ } NIL operation {}}", isLeft) - , ("{ DROP SWAP }", isLeft) - , ("{DROP ; SWAP;}", isRight) - , ("{{DROP}SWAP}", isRight) - , ("{DROP; DIP{SWAP}}", isRight) - ] - - , testGroup "delimiters inside type" $ (:) - -- delimiters inside type: there might be no space after - -- type if it's followed by one of @, | : ] .@ - ( satisfyingCasePredicate (P.letInner P.parsedOp) - "f :: forall a. '[int] -> '[a,int,...] = {PUSH int 1};" isRight) - ( testSatisfyingCasesPredicate P.type_ - [ ("(int,int)", isRight) - , ("(string|nat)", isRight) - , ("unit:u", isRight) - , ("[int]", isRight) - ] - ) - ] - ----------------------------------------------------------------------------- --- Others ----------------------------------------------------------------------------- - -test_printComment :: [TestTree] -test_printComment = testSatisfyingCases P.printComment - [ ( "\"Sides are %[0] x %[1]\"" - , Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)]) - ) - , ( "\"%[0] x\"" - , Right (PrintComment [Right (StackRef 0), Left " x"]) - ) - , ( "\"%[0]x%[1]\"" - , Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)]) - ) - , ( "\"%[0]%[1]\"" - , Right (PrintComment [Right (StackRef 0), Right (StackRef 1)]) - ) - , ( "\"xxx\"" - , Right (PrintComment [Left "xxx"]) - ) - , ( "\"\"" - , Right (PrintComment []) - ) - ] - -test_parser_exception :: [TestTree] -test_parser_exception = - [ handleCustomError "0x000" P.value OddNumberBytesException - , handleCustomError "Right 0x000" P.value OddNumberBytesException - , handleCustomError "\"aaa\\r\"" P.stringLiteral - (StringLiteralException (InvalidEscapeSequence 'r')) - , handleCustomError "\"aaa\\b\"" P.stringLiteral - (StringLiteralException (InvalidEscapeSequence 'b')) - , handleCustomError "\"aaa\\t\"" P.stringLiteral - (StringLiteralException (InvalidEscapeSequence 't')) - , handleCustomError "\"aaa\n\"" P.stringLiteral - (StringLiteralException (InvalidChar '\n')) - , handleCustomError "\"aaa\r\"" P.stringLiteral - (StringLiteralException (InvalidChar '\r')) - , handleCustomError "{ TAG 2 (int | string) }" P.codeEntry - (WrongTagArgs 2 (UnsafePositive 2)) - , handleCustomError "{ ACCESS 2 2 }" P.codeEntry - (WrongAccessArgs 2 (UnsafePositive 2)) - , handleCustomError "{ SET 2 2 }" P.codeEntry - (WrongSetArgs 2 (UnsafePositive 2)) - , handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };" - (P.letInner P.parsedOp) - (Tokens ('n' :| "")) - ] - -test_letType :: [TestTree] -test_letType = testSatisfyingCasesPredicate P.letType - [ ("type kek = int", isRight) - -- They used to be prohibited, but now we permit them. - , ("type Parameter = int", isRight) - , ("type Storage = int", isRight) - ] ----------------------------------------------------------------------------- --- Helpers ----------------------------------------------------------------------------- - -checkFile :: Bool -> FilePath -> IO () -checkFile shouldParse file = do - code <- Utf8.readFile file - case parse P.programExt file code of - Left err - | shouldParse -> assertFailure $ errorBundlePretty err - Right _ - | not shouldParse -> assertFailure $ "Managed to parse " <> file - _ -> pass - -handleCustomError - :: HasCallStack => Text -> Parser' LetEnv a -> CustomParserException -> TestTree -handleCustomError text parser customException = testCase (toString text) $ - case P.parseNoEnv parser codeSrc text of - Right _ -> assertFailure "expecting parser to fail" - Left bundle -> case toList $ bundleErrors bundle of - [FancyError _ (toList -> [ErrorCustom e])] -> - e `shouldBe` customException - _ -> - assertFailure $ - "expecting single ErrorCustom, but got " <> - errorBundlePretty bundle - -handleTrivialError - :: HasCallStack => Text -> Parser' LetEnv a -> ErrorItem Char -> TestTree -handleTrivialError text parser errorItem = testCase (toString text) $ - case P.parseNoEnv parser codeSrc text of - Right _ -> assertFailure "expecting parser to fail" - Left bundle -> case toList $ bundleErrors bundle of - [TrivialError _ e _] -> - e `shouldBe` (Just errorItem) - _ -> - assertFailure $ - "expecting single TrivialError, but got " <> - errorBundlePretty bundle - -satisfyingCasePredicate - :: Show a - => Parser' LetEnv a - -> Text - -> (Either (ParseErrorBundle Text CustomParserException) a -> Bool) - -> TestTree -satisfyingCasePredicate parser parsedExpression predicate = - testCase (toString parsedExpression) $ - P.parseNoEnv parser codeSrc parsedExpression `shouldSatisfy` predicate - -satisfyingCase - :: (Eq a, Show a) - => Parser' LetEnv a - -> Text - -> Either (ParseErrorBundle Text CustomParserException) a - -> TestTree -satisfyingCase parser parsedExpression expected = - satisfyingCasePredicate parser parsedExpression (== expected) - -testSatisfyingCases - :: (Eq a, Show a) - => Parser' LetEnv a - -> [(Text, Either (ParseErrorBundle Text CustomParserException) a)] - -> [TestTree] -testSatisfyingCases parser = map (uncurry $ satisfyingCase parser) - -testSatisfyingCasesPredicate - :: Show a - => Parser' LetEnv a - -> [(Text, Either (ParseErrorBundle Text CustomParserException) a -> Bool)] - -> [TestTree] -testSatisfyingCasesPredicate parser = map (uncurry $ satisfyingCasePredicate parser) diff --git a/morley-test/Test/Preprocess.hs b/morley-test/Test/Preprocess.hs deleted file mode 100644 --- a/morley-test/Test/Preprocess.hs +++ /dev/null @@ -1,63 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for preprocessing. - -module Test.Preprocess - ( unit_Sample_preprocess - ) where - -import Prelude hiding (EQ) - -import Test.HUnit (Assertion, (@?=)) - -import Morley.Michelson.Preprocess (transformBytes, transformStrings) -import Morley.Michelson.Text -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 (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 - f fn s - | s == (fn str1) = (fn str5) - | s == (fn str2) = (fn str4) - | s == (fn str4) = (fn str2) - | s == (fn str5) = (fn str1) - | otherwise = s - -sample :: (IsString i, T.ConstantScope o) => (i -> T.Value o) -> T.ContractCode o o -sample fn = - CAR `Seq` - PUSH (fn str1) `Seq` - DIP (PUSH (fn str2)) `Seq` - (AnnLEFT @('T.TKey) noAnn noAnn noAnn) `Seq` - IF_LEFT Nop (PUSH (fn str4) `Seq` FAILWITH) `Seq` - DIP (DIP (PUSH (fn str5))) `Seq` - PUSH (fn str3) `Seq` - DROP `Seq` DROP `Seq` DROP `Seq` DROP `Seq` - NIL `Seq` PAIR - -expected :: (IsString i, T.ConstantScope o) => (i -> T.Value o) -> T.ContractCode o o -expected fn = - CAR `Seq` - PUSH (fn str5) `Seq` - DIP (PUSH (fn str4)) `Seq` - (AnnLEFT @('T.TKey) noAnn noAnn noAnn) `Seq` - IF_LEFT Nop (PUSH (fn str2) `Seq` FAILWITH) `Seq` - DIP (DIP (PUSH (fn str1))) `Seq` - PUSH (fn str3) `Seq` - DROP `Seq` DROP `Seq` DROP `Seq` DROP `Seq` - NIL `Seq` PAIR - -str1, str2, str3, str4, str5 :: (IsString a) => a -str1 = "aa" -str2 = "ls" -str3 = "gulya" -str4 = "naiks" -str5 = "eek" diff --git a/morley-test/Test/Printer/Michelson.hs b/morley-test/Test/Printer/Michelson.hs deleted file mode 100644 --- a/morley-test/Test/Printer/Michelson.hs +++ /dev/null @@ -1,132 +0,0 @@ --- 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 - , unit_PrettyPrint - , unit_PrintTypedNotes - , unit_PrintSmartParens - , unit_PrintBigDipN - , unit_Views - ) where - -import Data.Text.IO.Utf8 qualified as Utf8 (readFile) -import Data.Text.Lazy (strip) -import Fmt (pretty) -import Generics.SYB (everywhere, mkT) -import Test.HUnit (Assertion, assertEqual, assertFailure, (@?=)) - -import Morley.Michelson.Parser (MichelsonSource(..)) -import Morley.Michelson.Printer (printSomeContract, printUntypedContract) -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) - -import Test.Util.Contracts -import Test.Util.HUnit - --- | Check that contract under the first given file, when parsed and printed --- back, produces the contract under the second file. -printerTest :: (FilePath, FilePath) -> Assertion -printerTest (srcPath, refPath) = do - checkedContract <- importSomeContract srcPath - targetSrc <- strip . fromStrict <$> Utf8.readFile refPath - assertEqualBuild - ("Prettifying " <> srcPath <> " does not match the expected format") - targetSrc - (printSomeContract False checkedContract) - -unit_PrintTypedNotes :: Assertion -unit_PrintTypedNotes = do - contracts <- getContractsWithReferences ".tz" (inContractsDir "notes-in-typed-contracts") "ref" - mapM_ printerTest contracts - -unit_PrintSmartParens :: Assertion -unit_PrintSmartParens = do - contracts <- getContractsWithReferences ".tz" (inContractsDir "smart-parens") "ref" - mapM_ printerTest contracts - -unit_PrintBigDipN :: Assertion -unit_PrintBigDipN = do - contracts <- getContractsWithReferences ".tz" (inContractsDir "big-dip") "ref" - mapM_ printerTest contracts - -unit_Views :: Assertion -unit_Views = do - contracts <- getContractsWithReferences ".tz" (inContractsDir "views") "ref" - mapM_ printerTest contracts - -unit_PrettyPrint :: Assertion -unit_PrettyPrint = do - contracts <- getContractsWithReferences ".tz" (inContractsDir "pretty") "pretty" - mapM_ prettyTest contracts - where - prettyTest :: (FilePath, FilePath) -> Assertion - prettyTest (srcPath, refPath) = do - contract <- importUntypedContract srcPath - targetSrc <- strip . fromStrict <$> Utf8.readFile refPath - assertEqual - ("Prettifying " <> srcPath <> " does not match the expected format") - (printUntypedContract False contract) - targetSrc - assertEqual - ("Single line pretty printer output " - <> srcPath <> " contain new lines.") - (find (=='\n') $ printUntypedContract True contract) Nothing - -unit_Roundtrip :: Assertion -unit_Roundtrip = do - morleyContractFiles <- getWellTypedMorleyContracts - mapM_ morleyRoundtripPrintTest morleyContractFiles - michelsonContractFiles <- getWellTypedMichelsonContracts - mapM_ michelsonRoundtripPrintTest michelsonContractFiles - where - morleyRoundtripPrintTest :: FilePath -> Assertion - morleyRoundtripPrintTest filePath = do - contract1 <- importUsing readUntypedContractExt filePath - contract2 <- printAndParse filePath contract1 - -- We don't expect that `contract1` equals `contract2`, - -- because during printing we lose extra instructions. - assertEqual ("After printing and parsing " <> filePath <> - " is printed differently") - (printUntypedContract True contract1) -- using single line output here - (printUntypedContract True contract2) - michelsonRoundtripPrintTest :: FilePath -> Assertion - michelsonRoundtripPrintTest filePath = do - contract1 <- importUntypedContract filePath - contract2 <- printAndParse filePath contract1 - -- We expect `contract1` equals `contract2`. - assertEqual ("After printing and parsing " <> filePath <> - " contracts are different") - (transformContract contract1) (transformContract contract2) - -unit_let_macro :: Assertion -unit_let_macro = do - let filePath = inContractsDir "ill-typed/letblock_trivial.mtz" - 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 parseExpandContractExt (MSFile fp) (toText $ printUntypedContract True contract1) of - Left err -> - assertFailure ("Failed to parse printed " <> fp <> ": " <> pretty err) - Right contract2 -> pure contract2 - --- | Remove all `WithSrcEx` from contract code because `SrcPos`es --- and such stuff can change during printing and parsing -transformContract :: U.Contract -> U.Contract -transformContract = U.mapContractCode transform - where - transform :: ExpandedOp -> ExpandedOp - transform = everywhere $ mkT removeWithSrcEx - removeWithSrcEx :: ExpandedOp -> ExpandedOp - removeWithSrcEx (WithSrcEx _ op) = op - removeWithSrcEx op = op diff --git a/morley-test/Test/Serialization/Aeson.hs b/morley-test/Test/Serialization/Aeson.hs deleted file mode 100644 --- a/morley-test/Test/Serialization/Aeson.hs +++ /dev/null @@ -1,52 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Serialization.Aeson - ( test_Roundtrip - ) where - -import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) -import Hedgehog (Gen) -import Test.Tasty (TestTree) - -import Hedgehog.Gen.Michelson.Untyped - (genAnnotation, genContract, genElt, genExpandedOp, genInstrAbstract, genStackFn, genValue) -import Hedgehog.Gen.Tezos.Core (genMutez, genTimestamp) -import Morley.Michelson.Untyped - (Contract, Elt, ExpandedOp, FieldAnn, InstrAbstract, StackFn, TypeAnn, Value, VarAnn) -import Morley.Tezos.Core (Mutez, Timestamp) - -import Test.Util.Hedgehog (roundtripTree) - - --- Note: if we want to enforce a particular JSON format, we can extend --- these test with golden tests (it's easy with `hspec-golden-aeson`). - -test - :: forall a. (Eq a, Show a, ToJSON a, FromJSON a, Typeable a) - => Gen a -> TestTree -test genA = roundtripTree @a genA encode eitherDecode - -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ -- Core Tezos types - test @Timestamp genTimestamp - , test @Mutez genMutez - - -- Michelson types - , test @StackFn genStackFn - , test @ExpandedOp genExpandedOp - - -- these are actually all the same thing (Annotation a), - -- where a is a phantom type, - -- but let's test them in case they - -- ever change for some reason - , test @TypeAnn genAnnotation - , test @FieldAnn genAnnotation - , test @VarAnn genAnnotation - - , test @Contract genContract - , test @(InstrAbstract ExpandedOp) (genInstrAbstract genExpandedOp) - , test @Value genValue - , test @(Elt ExpandedOp) (genElt genExpandedOp) - ] diff --git a/morley-test/Test/Serialization/Typed/Michelson.hs b/morley-test/Test/Serialization/Typed/Michelson.hs deleted file mode 100644 --- a/morley-test/Test/Serialization/Typed/Michelson.hs +++ /dev/null @@ -1,456 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE OverloadedLists #-} - -module Test.Serialization.Typed.Michelson - ( spec_Serialization - ) where - -import Data.Aeson qualified as J -import Data.Aeson.QQ (aesonQQ) -import Data.Typeable (typeRep) -import Test.Hspec (Spec, describe, it) - -import Morley.Michelson.Interpret (runUnpack) -import Morley.Michelson.Interpret.Pack (packValue') -import Morley.Michelson.Text -import Morley.Michelson.Typed -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 Morley.Tezos.Crypto.BLS12381 qualified as BLS -import Test.Cleveland.Instances () -import Test.Serialization.Util - -spec_Serialization :: Spec -spec_Serialization = do - describe "serialization tests for comparable typed values" $ do - bls12381Test - keyHashTest - timestampTest - addressTest - keyTest - chainIdTest - signatureTest - natTest - mutezTest - - describe "serialization tests for non-comparable values" $ do - contractTest - ticketTest - setTest - pairTest - - deserializeNegTest - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client hash data ... of type ...' -toBinaryTestMethod - :: ( HasCallStack - , PackedValScope t - ) - => [TestMethod (Value t)] -toBinaryTestMethod = toBinaryTestMethodImpl packValue' - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from michelson to binary' -fromBinaryTestMethod - :: forall t. - ( HasCallStack - , UnpackedValScope t - ) - => [TestMethod (Value t)] -fromBinaryTestMethod = fromBinaryTestMethodImpl (runUnpack @t) - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from michelson to json' -toJsonTestMethod - :: ( HasCallStack - , HasNoOp t - ) - => [TestMethod (Value t)] -toJsonTestMethod = toJsonTestMethodImpl - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from json to michelson' -fromJsonTestMethod - :: forall t. - ( HasCallStack - , SingI t - ) - => [TestMethod (Value t)] -fromJsonTestMethod = fromJsonTestMethodImpl @(Value t) - -allTestMethods - :: ( UnpackedValScope t - , HasCallStack - ) - => [TestMethod (Value t)] -allTestMethods = - mconcat - [ toBinaryTestMethod - , fromBinaryTestMethod - , toJsonTestMethod - , fromJsonTestMethod - ] - -serializeSpecManual - :: forall x (t :: T). - HasCallStack - => (x -> Value t) - -> String - -> [TestMethod (Value t)] - -> [Example (x, (Text, J.Value))] - -> Spec -serializeSpecManual toVal' name testMethods suites = - forM_ @[_] testMethods $ \(TestMethod mname method) -> - describe mname $ - describe name $ forM_ suites $ \(Example exampleName (x, (hex, json))) -> - it exampleName $ method (toVal' x) hex json - -serializeSpec - :: forall x (t :: T). - ( IsoValue x, ToT x ~ t - , UnpackedValScope t - , Typeable t - , HasCallStack - ) - => [Example (x, (Text, J.Value))] - -> Spec -serializeSpec = serializeSpecManual toVal typeName allTestMethods - where - typeName = show $ typeRep (Proxy @(Value t)) - -deserializeNegSpec - :: forall t. - UnpackedValScope t - => String - -> Text - -> J.Value - -> Spec -deserializeNegSpec = deserializeNegSpecImpl @(Value t) runUnpack - -rightCombedPairSpec - :: forall x. - ( IsoValue x - , UnpackedValScope (ToT x) - ) - => [Example (x, Text)] - -> Spec -rightCombedPairSpec suites = serializeSpecManual @x toVal name - (toBinaryTestMethod <> fromBinaryTestMethod) (mapSuites suites) - where - name = "Right-combed pairs are packed without optimizations" - - mapSuites :: [Example (x, Text)] -> [Example (x, (Text, J.Value))] - mapSuites = fmap (\(Example n (v, b)) -> Example n (v, (b, J.Null))) - -bls12381Test :: Spec -bls12381Test = do - serializeSpec - @Bls12381Fr - [ Example "Bls12381Fr" $ - (1 :: Bls12381Fr) - ~: "0x050a000000200100000000000000000000000000000000000000000000000000000000000000" - ~: [aesonQQ| { "bytes": "0100000000000000000000000000000000000000000000000000000000000000" } - |] - ] - serializeSpec - @Bls12381G1 - [ Example "Bls12381G1" $ - BLS.g1One - ~: "0x050a0000006017f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1" - ~: [aesonQQ| { "bytes": "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1" } - |] - ] - serializeSpec - @Bls12381G2 - [ Example "Bls12381G2" $ - BLS.g2One - ~: "0x050a000000c013e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801" - ~: [aesonQQ| { "bytes": "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801" } - |] - ] - -mutezTest :: Spec -mutezTest = - serializeSpec - @Mutez - [ 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 -natTest = - serializeSpec - @Natural - [ 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" }|] - ] - -setTest :: Spec -setTest = - serializeSpec - @(Set Integer) - [ Example "Empty set" $ - [] - ~: "050200000000" - ~: [aesonQQ| [ ] |] - , Example "Singleton set" $ - [1] - ~: "0502000000020001" - ~: [aesonQQ| [ { "int": "1" } ] |] - , Example "Set with many elements" $ - [0, 10, 24, 35, 100, 1000] - ~: "05020000000e0000000a0018002300a40100a80f" - ~: [aesonQQ| - [ { "int": "0" }, { "int": "10" }, { "int": "24" }, { "int": "35" }, - { "int": "100" }, { "int": "1000" } ] - |] - ] - -keyHashTest :: Spec -keyHashTest = do - serializeSpec - @KeyHash - [ Example "KeyHash" $ - unsafe (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") - ~: "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78" - ~: [aesonQQ| { "bytes": "0002298c03ed7d454a101eb7022bc95f7e5f41ac78" } |] - ] - -timestampTest :: Spec -timestampTest = do - serializeSpec @Timestamp $ examples $ convertTimestamps - [ 205027200 ~: "050080dec3c301" ~: [aesonQQ| { "int": "205027200" } |] - , 1552564995 ~: "0500838cd2c80b" ~: [aesonQQ| { "int": "1552564995" } |] - ] - where - convertTimestamps = map . first $ timestampFromSeconds - -addressTest :: Spec -addressTest = do - serializeSpec @Address $ examples $ parseAddrs - [ "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM" - ~: "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755" - ~: [aesonQQ| { "bytes": "00002addb327dbca405f07aeef318bba0ec2f714a755" } |] - , "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH" - ~: "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b" - ~: [aesonQQ| { "bytes": "000092b72c0fa1064331a641131f572e7f2abb9a890b" } |] - , "tz2EfqCbLmpfv7mNiLcMmhxAwdgHtPTcwR4W" - ~: "050a00000016000145b5e7d31bf6612e61ebfa7a6d929ce7800a55a4" - ~: [aesonQQ| { "bytes": "000145b5e7d31bf6612e61ebfa7a6d929ce7800a55a4" } |] - , "tz3UoffC7FG7zfpmvmjUmUeAaHvzdcUvAj6r" - ~: "050a0000001600025cfa532f50de3e12befc0ad21603835dd7698d35" - ~: [aesonQQ| { "bytes": "00025cfa532f50de3e12befc0ad21603835dd7698d35" } |] - , "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB" - ~: "050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200" - ~: [aesonQQ| { "bytes": "01122d038abd69be91b4b6803f2f098a088e259e7200" } |] - , "KT1NSrmSJrSueZiWPKrcAUScYr6k2BkUVALr" - ~: "050a00000016019812c669d9e8ff1a61bf8c57e33b955f074d832600" - ~: [aesonQQ| { "bytes": "019812c669d9e8ff1a61bf8c57e33b955f074d832600" } |] - ] - where - parseAddrs = map $ first (unsafe . parseAddress) - -keyTest :: Spec -keyTest = - serializeSpecManual VKey "key" allTestMethods $ examples - [ item "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - "050a00000021009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d" - [aesonQQ| { "bytes": "009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d" } |] - , item "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" - "050a0000002100aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082" - [aesonQQ| { "bytes": "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082" } |] - , item "sppk7cdA7Afj8MvuBFrP6KsTLfbM5DtH9GwYaRZwCf5tBVCz6UKGQFR" - "050a000000220103b524d0184276467c848ac13557fb0ff8bec5907960f72683f22af430503edfc1" - [aesonQQ| { "bytes": "0103b524d0184276467c848ac13557fb0ff8bec5907960f72683f22af430503edfc1" } |] - , item "sppk7Ze7NMs6EHF2uB8qq8GrEgJvE9PWYkUijN3LcesafzQuGyniHBD" - "050a0000002201022c380cd1ff286a0a1a7c3aad6e891d237fa82e2a7cdeec08ccb55e90fdef995f" - [aesonQQ| { "bytes": "01022c380cd1ff286a0a1a7c3aad6e891d237fa82e2a7cdeec08ccb55e90fdef995f" } |] - , item "p2pk67K1dwkDFPB63RZU5H3SoMCvmJdKZDZszc7U4FiGKN2YypKdDCB" - "050a00000022020368afbb09255d849813712108a4144237dc1fdd5bb74e68335f4c68c12c1e5723" - [aesonQQ| { "bytes": "020368afbb09255d849813712108a4144237dc1fdd5bb74e68335f4c68c12c1e5723" } |] - , item "p2pk68C6tJr7pNLvgBH63K3hBVoztCPCA36zcWhXFUGywQJTjYBfpxk" - "050a000000220203dcb1916c475902f2b1083212e1b4e6f8ce1531710218c7d34340439f47040e7c" - [aesonQQ| { "bytes": "0203dcb1916c475902f2b1083212e1b4e6f8ce1531710218c7d34340439f47040e7c" } |] - ] - where - item keyStr keyBytes json = ( unsafe $ parsePublicKey keyStr, (keyBytes, json) ) - -chainIdTest :: Spec -chainIdTest = - serializeSpecManual VChainId "chain_id" allTestMethods $ examples - [ unsafe - (parseChainId "NetXUdfLh6Gm88t") - ~: "0x050a00000004458aa837" - ~: [aesonQQ| { "bytes": "458aa837" } |] - ] - -signatureTest :: Spec -signatureTest = - serializeSpecManual VSignature "signature" allTestMethods $ examples - [ item "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8\ - \ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" - "050a0000004091ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232d\ - \b34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201" - [aesonQQ| { "bytes" : "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201"} |] - , item "spsig1Ng2bs4PXCbjaFGuojk9K5Pt3CkfbUZyHLLrBxHSmTq\ - \rUUxQggi4yJBit3Ljqnqr61UpdTewTLiu4schSCfZvaRwu412oZ" - "0x050a0000004080e4e72ffecf72953789625b1125e9f45f432c14e53a01ec68a1e1b77\ - \d60cfe96a97443733ba0f7f42db3a56d7a433df2b4fc0035c05ab92d062f33c5bab0244" - [aesonQQ| { "bytes": "80e4e72ffecf72953789625b1125e9f45f432c14e53a01ec68a1e1b77d60cfe96a97443733ba0f7f42db3a56d7a433df2b4fc0035c05ab92d062f33c5bab0244" } |] - , item "p2sigRmXDp38VNVaEQH28LYukfLPn8QB5hPEberhvQrrUpRs\ - \cDZJrrApbRh2u46PTVTwKXjxTLKNN9dyLhPQU6U6jWPGxe4d9v" - "0x050a00000040222222222222222222222222222222222222222222222222222222222\ - \22222222222222222222222222222222222222222222222222222222222222222222222" - [aesonQQ| { "bytes": "22222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222" } |] - , item "sigrZRt6CTBNtRzjMFQYSZhUm1QcDg5gopVgiRTLMQsgikeR\ - \LmrmsA5vmFqjrnBhofzqvKtc9k5VhTzCMCio5epRvu9no73S" - "0x050a00000040da632d7f267673fab5a40562778a6890b6ada9665d53d7ff318e3399e\ - \032b3986588dadcf3bf3b549592f7b8ea1365273fbef5f4883c3430ed32e8ae24017be1" - [aesonQQ| { "bytes": "da632d7f267673fab5a40562778a6890b6ada9665d53d7ff318e3399e032b3986588dadcf3bf3b549592f7b8ea1365273fbef5f4883c3430ed32e8ae24017be1" } |] - ] - where - item sigStr sigBytes json = (unsafe $ parseSignature sigStr, (sigBytes, json)) - -contractTest :: Spec -contractTest = do - serializeSpecManual (addressToVContract @'TUnit) "simple contract" - (toBinaryTestMethod <> toJsonTestMethod) $ - examples $ parseAddrs $ - [ "tz1PYgf9fBGLXvwx8ag8sdwjLJzmyGdNiswM" - ~: "050a0000001600002addb327dbca405f07aeef318bba0ec2f714a755" - ~: [aesonQQ| { "bytes": "00002addb327dbca405f07aeef318bba0ec2f714a755" } |] - , "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH" - ~: "050a00000016000092b72c0fa1064331a641131f572e7f2abb9a890b" - ~: [aesonQQ| { "bytes": "000092b72c0fa1064331a641131f572e7f2abb9a890b" } |] - ] - - serializeSpecManual (addressToVContract @'TInt) "non-unit contract" - (toBinaryTestMethod <> toJsonTestMethod) $ - examples $ parseAddrs $ - [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB" - ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200" - ~: [aesonQQ| { "bytes": "01122d038abd69be91b4b6803f2f098a088e259e7200" } |] - ] - - serializeSpecManual (mkEpVContract @'TInt) "contract with entrypoint" toBinaryTestMethod $ examples $ parseEpAddrs - [ "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%" - ~: "0x050a0000001601122d038abd69be91b4b6803f2f098a088e259e7200" - ~: [aesonQQ| { "bytes": "01122d038abd69be91b4b6803f2f098a088e259e7200" } |] - , "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB%abacaba" - ~: "0x050a0000001d01122d038abd69be91b4b6803f2f098a088e259e720061626163616261" - ~: [aesonQQ| { "bytes": "01122d038abd69be91b4b6803f2f098a088e259e720061626163616261" } |] - , "tz1Z1nn9Y7vzyvtf6rAYMPhPNGqMJXw88xGH%a" - ~: "0x050a00000017000092b72c0fa1064331a641131f572e7f2abb9a890b61" - ~: [aesonQQ| { "bytes": "000092b72c0fa1064331a641131f572e7f2abb9a890b61" } |] - ] - where - parseAddrs = map $ first (unsafe . parseAddress) - parseEpAddrs = map $ first (unsafe . parseEpAddress) - - mkEpVContract :: forall p. ParameterScope p => EpAddress -> Value ('TContract p) - mkEpVContract EpAddress{..} = - VContract eaAddress (SomeEpc unsafeEpcCallRoot{ epcName = eaEntrypoint }) - -ticketTest :: Spec -ticketTest = do - serializeSpecManual toVal "simple ticket" - toJsonTestMethod $ examples $ - [ Ticket - { tTicketer = unsafe $ parseAddress "tz1Zk7f1Ywii8QS11L63YqqtcneB64QWBas9" - , tData = [mt|a|] - , tAmount = 10 - } - ~: "" -- tickets are not packable, not testing the binary representation - ~: [aesonQQ| - [ { "bytes": "00009ab866724d89b5077cd943dfd00547e95c963d75" }, - { "string": "a" }, - { "int": "10" } - ] - |] - ] - -deserializeNegTest :: Spec -deserializeNegTest = do - describe "Bad entries order" $ do - deserializeNegSpec @('TSet 'TInt) "Unordered set elements" - "0x050200000006000300020001" -- { 3; 2; 1 } - [aesonQQ| [ { "int": "3" }, { "int": "2" }, { "int": "1" } ] |] - deserializeNegSpec @('TMap 'TInt $ 'TInt) "Unordered map elements" - "0x05020000000c070400020006070400010007" -- { Elt 2 6; Elt 1 7 } - [aesonQQ| - [ { "prim": "Elt", "args": [ { "int": "2" }, { "int": "6" } ] }, - { "prim": "Elt", "args": [ { "int": "1" }, { "int": "7" } ] } ] - |] - - describe "Type check failures" $ do - deserializeNegSpec @('TUnit) "Value type mismatch" - "0x050008" -- 8 - [aesonQQ| { "int": "8" } |] - deserializeNegSpec @('TLambda 'TUnit 'TKey) "Lambda type mismatch" - "0x050200000000" -- {} - [aesonQQ| [] |] - deserializeNegSpec @('TLambda 'TUnit 'TKey) "Lambda too large output stack size" - "0x0502000000060743035b0005" -- {PUSH int 5} - [aesonQQ| [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "5" } ] } ] |] - deserializeNegSpec @('TLambda 'TUnit 'TKey) "Lagmbda empty output stack size" - "0x0502000000020320" -- {DROP} - [aesonQQ| [ { "prim": "DROP" } ] |] - -pairTest :: Spec -pairTest = do - - rightCombedPairSpec - @(Integer, (Integer, Integer)) $ - examples - [ (1, (1, 2)) - -- > tezos-client hash data 'Pair 1 (Pair 1 2)' of type 'pair int int int' - ~: "0507070001070700010002" - ] - - rightCombedPairSpec - @((Integer, (MText, Integer)), ((Integer, (MText, Integer)), (Integer, (MText, Integer)))) $ - examples - [ ((1, ("a", 2)), ((3, ("b", 4)), (5, ("c", 6)))) - -- > tezos-client hash data '(Pair (Pair 1 (Pair "a" 2)) (Pair (Pair 3 (Pair "b" 4)) (Pair 5 (Pair "c" 6))))' - -- of type 'pair (pair int string int) (pair int string int) int string int' - ~: "0507070707000107070100000001610002070707070003070701000000016200040707000507070100000001630006" - ] - - rightCombedPairSpec - @(MText, Integer) $ - examples - [ ("Good Night!", 5) - -- > tezos-client hash data 'Pair "Good Night!" 5' of type 'pair string int' - ~: "050707010000000b476f6f64204e69676874210005" - ] - - rightCombedPairSpec - @(Integer, (Integer, (MText, Integer))) $ - examples - [ (1, (2, ("Some text", 3))) - -- > tezos-client hash data 'Pair 1 (Pair 2 (Pair "Some text" 3))' of type 'pair int int string int' - ~: "05070700010707000207070100000009536f6d6520746578740003" - ] diff --git a/morley-test/Test/Serialization/Untyped/Michelson.hs b/morley-test/Test/Serialization/Untyped/Michelson.hs deleted file mode 100644 --- a/morley-test/Test/Serialization/Untyped/Michelson.hs +++ /dev/null @@ -1,2895 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE OverloadedLists #-} - -module Test.Serialization.Untyped.Michelson - ( spec_Serialization - ) where - -import Prelude hiding (Ordering(..)) - -import Data.Aeson qualified as J -import Data.Aeson.QQ (aesonQQ) -import Fmt (pretty) -import Test.Hspec (Spec, describe, it, shouldSatisfy) -import Test.Hspec.Expectations (expectationFailure) - -import Morley.Micheline (Expression, fromExpression, toExpression) -import Morley.Michelson.Interpret (runUnpack) -import Morley.Michelson.Interpret.Pack (packValue', packValuePrefix, toBinary') -import Morley.Michelson.Interpret.Unpack (unpackUValue', unpackValue') -import Morley.Michelson.Macro (expandList) -import Morley.Michelson.Parser qualified as Parser -import Morley.Michelson.Typed -import Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Core (ChainId(..)) -import Test.Cleveland.Instances (HasInstrCallStack(..)) -import Test.Cleveland.Util -import Test.Serialization.Util -import Test.Util.Parser - -spec_Serialization :: Spec -spec_Serialization = do - describe "serialization tests for comparable values (CValue)" $ do - unitTest - intTest - stringTest - bytesTest - boolTest - optionTest - orTest - - describe "serialization tests for non-comparable values" $ do - seqTest - mapTest - - describe "serialization tests for instructions" $ do - instrTest - typesTest - - deserializeNegTest - readableDeserializeTest - lengthsAreNotIgnoredTest - deserializeIntAsNatTest - deserializeComparablePairTest - deserializeComparableOrTest - deserializeComparableOptionTest - deserializeComparablesTest - deserializeSeqOfEmptySeqsTest - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from michelson to binary' -toBinaryTestMethod :: HasCallStack => [TestMethod U.Value] -toBinaryTestMethod = toBinaryTestMethodImpl (\v -> packValuePrefix <> toBinary' v) - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from binary to michelson' -fromBinaryTestMethod :: HasCallStack => [TestMethod U.Value] -fromBinaryTestMethod = fromBinaryTestMethodImpl unpackUValue' - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from michelson to json' -toJsonTestMethod :: HasCallStack => [TestMethod U.Value] -toJsonTestMethod = toJsonTestMethodImpl - --- | Test method that checks that the conversion result is equal --- to the result of 'tezos-client convert data ... from json to michelson' -fromJsonTestMethod :: HasCallStack => [TestMethod U.Value] -fromJsonTestMethod = fromJsonTestMethodImpl @U.Value - -allTestMethods :: HasCallStack => [TestMethod U.Value] -allTestMethods = - mconcat - [ toBinaryTestMethod - , fromBinaryTestMethod - , toJsonTestMethod - , fromJsonTestMethod - ] - -serializeSpecManual - :: HasCallStack - => String - -> [TestMethod U.Value] - -> [Example (U.Value, (Text, J.Value))] - -> Spec -serializeSpecManual = serializeSpecManualImpl id - -serializeSpec - :: HasCallStack - => String - -> [Example (U.Value, (Text, J.Value))] - -> Spec -serializeSpec name = serializeSpecManual name allTestMethods - -parseSerializeSpec :: HasCallStack => String -> [(Text, (Text, J.Value))] -> Spec -parseSerializeSpec name suites = parseLambdaSpec name allTestMethods suites - -parseDeserializeOnlySpec :: String -> [(Text, (Text, J.Value))] -> Spec -parseDeserializeOnlySpec name suites = - parseLambdaSpec name (fromBinaryTestMethod <> fromJsonTestMethod) suites - -parseLambdaSpec - :: String - -> [TestMethod U.Value] - -> [(Text, (Text, J.Value))] - -> Spec -parseLambdaSpec name testMethods suites = - forM_ @[_] testMethods $ \(TestMethod mname method) -> - describe mname $ - describe name $ forM_ suites $ \(codeText, (packed, json)) -> - it (truncateName $ toString codeText) $ do - parsed <- Parser.codeEntry `shouldParse` ("{" <> codeText <> "}") - let code = expandList parsed - let lambda = withoutIcs . U.ValueLambda <$> (nonEmpty code) ?: U.ValueNil - method lambda packed json - where - truncateName s - | length s < 60 = s - | otherwise = take 60 s <> " ..." - -unpackNegSpec :: String -> Text -> Spec -unpackNegSpec name encodedHex = - it name $ - let encoded = unsafe . fromHex $ stripOptional0x encodedHex - in unpackUValue' encoded `shouldSatisfy` isLeft - -deserializeNegSpec :: String -> Text -> J.Value -> Spec -deserializeNegSpec = deserializeNegSpecImpl @U.Value unpackUValue' - -intTest :: Spec -intTest = - serializeSpec "ValueInt" - [ Example "-64" $ U.ValueInt -64 ~: "0500c001" ~: [aesonQQ| { "int": "-64" } |] - , Example "-63" $ U.ValueInt -63 ~: "05007f" ~: [aesonQQ| { "int": "-63"} |] - , Example "-2" $ U.ValueInt -2 ~: "050042" ~: [aesonQQ| { "int": "-2"} |] - , Example "-1" $ U.ValueInt -1 ~: "050041" ~: [aesonQQ| { "int": "-1"} |] - , Example "0" $ U.ValueInt 0 ~: "050000" ~: [aesonQQ| { "int": "0"} |] - , Example "1" $ U.ValueInt 1 ~: "050001" ~: [aesonQQ| { "int": "1"} |] - , Example "2" $ U.ValueInt 2 ~: "050002" ~: [aesonQQ| { "int": "2"} |] - , Example "63" $ U.ValueInt 63 ~: "05003f" ~: [aesonQQ| { "int": "63"} |] - , Example "64" $ U.ValueInt 64 ~: "05008001" ~: [aesonQQ| { "int": "64"} |] - , Example "65" $ U.ValueInt 65 ~: "05008101" ~: [aesonQQ| { "int": "65"} |] - , Example "-65" $ U.ValueInt -65 ~: "0500c101" ~: [aesonQQ| { "int": "-65"} |] - , Example "127" $ U.ValueInt 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127"} |] - , Example "128" $ U.ValueInt 128 ~: "05008002" ~: [aesonQQ| { "int": "128"} |] - , Example "129" $ U.ValueInt 129 ~: "05008102" ~: [aesonQQ| { "int": "129"} |] - , Example "-127" $ U.ValueInt -127 ~: "0500ff01" ~: [aesonQQ| { "int": "-127"} |] - , Example "191" $ U.ValueInt 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191"} |] - , Example "192" $ U.ValueInt 192 ~: "05008003" ~: [aesonQQ| { "int": "192"} |] - , Example "193" $ U.ValueInt 193 ~: "05008103" ~: [aesonQQ| { "int": "193"} |] - , Example "2028" $ U.ValueInt 2028 ~: "0500ac1f" ~: [aesonQQ| { "int": "2028"} |] - , Example "5000" $ U.ValueInt 5000 ~: "0500884e" ~: [aesonQQ| { "int": "5000"} |] - , Example "10000" $ U.ValueInt 10000 ~: "0500909c01" ~: [aesonQQ| { "int": "10000"} |] - , Example "20000" $ U.ValueInt 20000 ~: "0500a0b802" ~: [aesonQQ| { "int": "20000"} |] - , Example "-5000" $ U.ValueInt -5000 ~: "0500c84e" ~: [aesonQQ| { "int": "-5000"} |] - , Example "-10000" $ U.ValueInt -10000 ~: "0500d09c01" ~: [aesonQQ| { "int": "-10000"} |] - , Example "-20000" $ U.ValueInt-20000 ~: "0500e0b802" ~: [aesonQQ| { "int": "-20000"} |] - ] - -stringTest :: Spec -stringTest = - serializeSpec "ValueString" - [ Example "Hello World!" $ - (U.ValueString "Hello World!") - ~: "05010000000c48656c6c6f20576f726c6421" - ~: [aesonQQ| { "string": "Hello World!" } |] - , Example "HODL: Hold On for Dear Life" $ - (U.ValueString "HODL: Hold On for Dear Life") - ~: "05010000001b484f444c3a20486f6c64204f6e20666f722044656172204c696665" - ~: [aesonQQ| { "string": "HODL: Hold On for Dear Life" } |] - , Example "Newline" $ - (U.ValueString "\n") - ~: "0501000000010a" - ~: [aesonQQ| { "string": "\n" } |] - ] - -bytesTest :: Spec -bytesTest = - serializeSpec "ValueBytes" - [ Example "Numerical" $ - (U.ValueBytes $ U.InternalByteString "000123") - ~: "050a00000006303030313233" - -- > Text.Hex.encodeHex "000123" - ~: [aesonQQ| { "bytes": "303030313233"} |] - , Example "Alphabetical" $ - (U.ValueBytes $ U.InternalByteString "A rose by any other name would smell as sweet") - ~: "050a0000002d4120726f736520627920616e79206f74686572206e616\ - \d6520776f756c6420736d656c6c206173207377656574" - -- > Text.Hex.encodeHex "A rose by any other name would smell as sweet" - ~: [aesonQQ| { "bytes": "4120726f736520627920616e79206f74686572206e616d6520776f756c6420736d656c6c206173207377656574" } |] - ] - -boolTest :: Spec -boolTest = - serializeSpec "ValueTrue, ValueFalse" - [ Example "True" $ U.ValueTrue ~: "05030a" ~: [aesonQQ| { "prim": "True"} |] - , Example "False" $ U.ValueFalse ~: "050303" ~: [aesonQQ| { "prim": "False"} |] - ] - -unitTest :: Spec -unitTest = - serializeSpec "ValueUnit" - [ Example "Unit" $ - U.ValueUnit - ~: "05030b" - ~: [aesonQQ|{ "prim": "Unit" }|] - ] - -optionTest :: Spec -optionTest = do - serializeSpec "ValueSome" - [ Example "Just" $ - (U.ValueSome $ U.ValueInt 123) - ~: "05050900bb01" - ~: [aesonQQ| { "prim": "Some", "args": [ { "int": "123" } ] } |] - , Example "Nothing" $ U.ValueNone - ~: "050306" - ~: [aesonQQ| { "prim": "None" } |] - ] - serializeSpec "ValueSome" - [ Example "Just" $ - (U.ValueSome $ U.ValueString "Goodnight World!") - ~: "0505090100000010476f6f646e6967687420576f726c6421" - ~: [aesonQQ| { "prim": "Some", "args": [ { "string": "Goodnight World!" } ] } |] - ] - -seqTest :: Spec -seqTest = - serializeSpec "ValueSeq" - [ Example "Empty seq" $ - U.ValueNil - ~: "050200000000" - ~: [aesonQQ| [] |] - , Example "Singleton seq" $ - (U.ValueSeq $ U.ValueInt 1 :| []) - ~: "0502000000020001" - ~: [aesonQQ| [ { "int": "1" } ] |] - , Example "Seq with many elements" $ - (U.ValueSeq $ U.ValueInt 1 :| [U.ValueInt 2, U.ValueInt 3]) - ~: "050200000006000100020003" - ~: [aesonQQ| [ { "int": "1" }, { "int": "2" }, { "int": "3" } ] |] - ] - -orTest :: Spec -orTest = - serializeSpec "ValueLeft, ValueRight" - [ Example "Left" $ - (U.ValueLeft $ U.ValueString "Error") - ~: "05050501000000054572726f72" - ~: [aesonQQ| { "prim": "Left", "args": [ { "string": "Error" } ] } |] - , Example "Right" $ - U.ValueRight U.ValueTrue - ~: "050508030a" - ~: [aesonQQ| { "prim": "Right", "args": [ { "prim": "True" } ] } |] - ] - -mapTest :: Spec -mapTest = do - serializeSpec "ValueMap" - [ Example "Empty map" $ - U.ValueNil - ~: "050200000000" - ~: [aesonQQ| [] |] - , Example "Non-empty map" $ - (U.ValueMap $ (U.Elt (U.ValueInt 0) (U.ValueString "Hello")) :| - [ U.Elt (U.ValueInt 1) (U.ValueString "Goodbye") - , U.Elt (U.ValueInt 2) (U.ValueString "Goodnight") - ]) - ~: "05020000003007040000010000000548656c6c6f07040001010000000\ - \7476f6f64627965070400020100000009476f6f646e69676874" - ~: [aesonQQ| - [ { "prim": "Elt", "args": [ { "int": "0" }, { "string": "Hello" } ] }, - { "prim": "Elt", "args": [ { "int": "1" }, { "string": "Goodbye" } ] }, - { "prim": "Elt", "args": [ { "int": "2" }, { "string": "Goodnight" } ] } ] - |] - ] - - serializeSpec "ValueMap" $ - examples - [ (U.ValueMap $ (U.Elt (U.ValueString "Lancaster") (U.ValueSeq $ (U.ValueInt 22323) :| [U.ValueFalse])) :| - [ U.Elt (U.ValueString "Stuart") (U.ValueSeq $ (U.ValueInt -832988) :| [U.ValueTrue]) - , U.Elt (U.ValueString "Tudor") (U.ValueSeq $ (U.ValueInt 123) :| [U.ValueTrue]) - ]) - ~: "050200000049070401000000094c616e636173746572020000000600b3\ - \dc02030307040100000006537475617274020000000600dcd765030a07\ - \0401000000055475646f72020000000500bb01030a" - ~: [aesonQQ| - [ { "prim": "Elt", - "args": - [ { "string": "Lancaster" }, - [ { "int": "22323" }, { "prim": "False" } ] ] }, - { "prim": "Elt", - "args": - [ { "string": "Stuart" }, - [ { "int": "-832988" }, { "prim": "True" } ] ] }, - { "prim": "Elt", - "args": - [ { "string": "Tudor" }, - [ { "int": "123" }, { "prim": "True" } ] ] } ] - |] - ] - -instrTest :: Spec -instrTest = do - -- The binary values we compare against are produced with command - -- > tezos-client convert data "{ $instrs }" from michelson to binary - -- - -- The json values are produced with: - -- > tezos-client convert data '{ $instrs }' from michelson to json - - parseSerializeSpec "instr" - [ "" - ~: "0x050200000000" - ~: [aesonQQ| [] |] - , "PUSH int 1; DROP" - ~: "0x0502000000080743035b00010320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "DROP" } ] - |] - , "DUP; SWAP; DROP" - ~: "0x0502000000060321034c0320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "SWAP" }, { "prim": "DROP" } ] - |] - , "DUP 1; SWAP; DROP" - ~: "0x05020000000805210001034c0320" - ~: [aesonQQ| - [ { "prim": "DUP", "args": [ { "int": "1" } ] }, { "prim": "SWAP" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 1; DUP 2; DROP; DROP; DROP" - ~: "0x05020000001607430362000107430362000105210002032003200320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "DUP", "args": [ { "int": "2" } ] }, - { "prim": "DROP" }, { "prim": "DROP" }, { "prim": "DROP" } ] - |] - , "UNIT; DUUP; DROP 2" - ~: "0x05020000000a034f0521000205200002" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "DUP", "args": [ { "int": "2" } ] }, - { "prim": "DROP", "args": [ { "int": "2" } ] } ] - |] - , "UNIT; UNIT; DUUUP; DROP 3" - ~: "0x05020000000c034f034f0521000305200003" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "UNIT" }, - { "prim": "DUP", "args": [ { "int": "3" } ] }, - { "prim": "DROP", "args": [ { "int": "3" } ] } ] - |] - , "DIG 0" - ~: "0x05020000000405700000" - ~: [aesonQQ| - [ { "prim": "DIG", "args": [ { "int": "0" } ] } ] - |] - , "UNIT; DIG 1; DIP { DROP }" - ~: "0x05020000000f034f05700001051f02000000020320" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "DIG", "args": [ { "int": "1" } ] }, - { "prim": "DIP", "args": [ [ { "prim": "DROP" } ] ] } ] - |] - , "DUG 0" - ~: "0x05020000000405710000" - ~: [aesonQQ| - [ { "prim": "DUG", "args": [ { "int": "0" } ] } ] - |] - , "UNIT; DUG 1; DIP { DROP }" - ~: "0x05020000000f034f05710001051f02000000020320" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "DUG", "args": [ { "int": "1" } ] }, - { "prim": "DIP", "args": [ [ { "prim": "DROP" } ] ] } ] - |] - , "UNIT; DROP" - ~: "0x050200000004034f0320" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "DROP" } ] - |] - , "UNIT :u; DROP" - ~: "0x05020000000a044f000000023a750320" - ~: [aesonQQ| - [ { "prim": "UNIT", "annots": [ ":u" ] }, { "prim": "DROP" } ] - |] - , "UNIT; DROP 1" - ~: "0x050200000006034f05200001" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "DROP", "args": [ { "int": "1" } ] } ] - |] - , "DROP 0" - ~: "0x05020000000405200000" - ~: [aesonQQ| - [ { "prim": "DROP", "args": [ { "int": "0" } ] } ] - |] - , "UNIT; UNIT; UNIT; DROP 3" - ~: "0x05020000000a034f034f034f05200003" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "UNIT" }, { "prim": "UNIT" }, - { "prim": "DROP", "args": [ { "int": "3" } ] } ] - |] - , "PUSH int 1; SOME; IF_NONE {} {DROP}" - ~: "0x0502000000160743035b00010346072f020000000002000000020320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "SOME" }, - { "prim": "IF_NONE", "args": [ [], [ { "prim": "DROP" } ] ] } ] - |] - , "PUSH int 1; SOME; IF_SOME {DROP} {}" - ~: "0x05020000001b0743035b00010346020000000e072f020000000002000000020320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "SOME" }, - [ { "prim": "IF_NONE", "args": [ [], [ { "prim": "DROP" } ] ] } ] ] - |] - , "PUSH int 1; SOME :s; IF_SOME {DROP} {}" - ~: "0x0502000000210743035b00010446000000023a73020000000e072f020000000\ - \002000000020320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "SOME", "annots": [ ":s" ] }, - [ { "prim": "IF_NONE", "args": [ [], [ { "prim": "DROP" } ] ] } ] ] - |] - , "NONE int; DROP" - ~: "0x050200000006053e035b0320" - ~: [aesonQQ| - [ { "prim": "NONE", "args": [ { "prim": "int" } ] }, { "prim": "DROP" } ] - |] - , "NONE :n int; DROP" - ~: "0x05020000000c063e035b000000023a6e0320" - ~: [aesonQQ| - [ { "prim": "NONE", "args": [ { "prim": "int" } ], "annots": [ ":n" ] }, - { "prim": "DROP" } ] - |] - , "PUSH int 1; PAIR; CAR" - ~: "0x05020000000a0743035b000103420316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR" }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR %a %b; CAR @%" - ~: "0x0502000000190743035b000104420000000525612025620416000000024025" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%a", "%b" ] }, - { "prim": "CAR", "annots": [ "@%" ] } ] - |] - , "PUSH int 1; PAIR %a %b; CAR @%%" - ~: "0x05020000001a0743035b00010442000000052561202562041600000003402525" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%a", "%b" ] }, - { "prim": "CAR", "annots": [ "@%%" ] } ] - |] - , "PUSH int 1; PAIR :p; CAR" - ~: "0x0502000000100743035b00010442000000023a700316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ ":p" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR % %o; CAR" - ~: "0x0502000000120743035b00010442000000042520256f0316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%", "%o" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR %o %; CAR" - ~: "0x0502000000100743035b0001044200000002256f0316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%o" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR %o; CAR" - ~: "0x0502000000100743035b0001044200000002256f0316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%o" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR :p %l %r; CAR" - ~: "0x0502000000160743035b00010442000000083a7020256c2025720316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ ":p", "%l", "%r" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR %l %r; CAR %l" - ~: "0x0502000000190743035b0001044200000005256c202572041600000002256c" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%l", "%r" ] }, - { "prim": "CAR", "annots": [ "%l" ] } ] - |] - , "PUSH int 1; PAIR %l %r; CDR %r" - ~: "0x0502000000190743035b0001044200000005256c2025720417000000022572" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%l", "%r" ] }, - { "prim": "CDR", "annots": [ "%r" ] } ] - |] - , "PUSH int 1; PAIR %l %r; CDR @%" - ~: "0x0502000000190743035b0001044200000005256c2025720417000000024025" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%l", "%r" ] }, - { "prim": "CDR", "annots": [ "@%" ] } ] - |] - , "PUSH int 1; PAIR %l %r; CDR @%%" - ~: "0x05020000001a0743035b0001044200000005256c202572041700000003402525" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%l", "%r" ] }, - { "prim": "CDR", "annots": [ "@%%" ] } ] - |] - , "PUSH int 1; PAIR % %@; CAR" - ~: "0x0502000000120743035b0001044200000004252025400316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ "%", "%@" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR :p % %@ @p; CAR" - ~: "0x0502000000180743035b000104420000000a3a7020252025402040700316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "annots": [ ":p", "%", "%@", "@p" ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR 2; CAR" - ~: "0x05020000000c0743035b0001054200020316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "args": [ { "int": "2" } ] }, { "prim": "CAR" } ] - |] - , "PUSH nat 1; PUSH bool True; PUSH int 1; PAIR 4; CAR" - ~: "0x05020000001807430362000107430359030a0743035b0001054200040316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "bool" }, { "prim": "True" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "args": [ { "int": "4" } ] }, { "prim": "CAR" } ] - |] - , "DUP; DUP; DUP; PAIR 4; UNPAIR 3; DIP { DROP 2 }" - ~: "0x05020000001903210321032105420004057a0003051f020000000405200002" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "DUP" }, { "prim": "DUP" }, - { "prim": "PAIR", "args": [ { "int": "4" } ] }, - { "prim": "UNPAIR", "args": [ { "int": "3" } ] }, - { "prim": "DIP", - "args": [ [ { "prim": "DROP", "args": [ { "int": "2" } ] } ] ] } ] - |] - , "DUP; PAIR; UNPAIR %a %b @c @d; DROP;" - ~: "0x05020000001703210342047a0000000b25612025622040632040640320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "PAIR" }, - { "prim": "UNPAIR", "annots": [ "%a", "%b", "@c", "@d" ] }, - { "prim": "DROP" } ] - |] - , "DUP; PAIR; UNPAIR @% @%%; DROP;" - ~: "0x05020000001203210342047a000000064025204025250320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "PAIR" }, - { "prim": "UNPAIR", "annots": [ "@%", "@%%" ] }, { "prim": "DROP" } ] - |] - , "LEFT unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x0502000000180533036c072e0200000000020000000803200743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "LEFT :lu %l %r unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x0502000000250633036c000000093a6c7520256c202572072e0200000000020\ - \000000803200743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ], - "annots": [ ":lu", "%l", "%r" ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "RIGHT unit; IF_RIGHT {} { DROP; PUSH int 1 }" - ~: "0x05020000001d0544036c0200000014072e020000000803200743035b00010200000000" - ~: [aesonQQ| - [ { "prim": "RIGHT", "args": [ { "prim": "unit" } ] }, - [ { "prim": "IF_LEFT", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ], - [] ] } ] ] - |] - - , "LEFT :lu %l unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x0502000000220633036c000000063a6c7520256c072e0200000000020000000\ - \803200743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ], - "annots": [ ":lu", "%l" ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "RIGHT :lu %l unit; IF_RIGHT {} { DROP; PUSH int 1 }" - ~: "0x0502000000270644036c000000063a6c7520256c0200000014072e020000000\ - \803200743035b00010200000000" - ~: [aesonQQ| - [ { "prim": "RIGHT", "args": [ { "prim": "unit" } ], - "annots": [ ":lu", "%l" ] }, - [ { "prim": "IF_LEFT", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ], - [] ] } ] ] - |] - , "LEFT :lu %@ %r unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x0502000000250633036c000000093a6c75202540202572072e0200000000020\ - \000000803200743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ], - "annots": [ ":lu", "%@", "%r" ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "LEFT :lu %@ %r @vl unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x0502000000290633036c0000000d3a6c752025402025722040766c072e020\ - \0000000020000000803200743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ], - "annots": [ ":lu", "%@", "%r", "@vl" ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "RIGHT :ru % %@ unit; IF_RIGHT {} { DROP; PUSH int 1 }" - ~: "0x0502000000290644036c000000083a727520252025400200000014072e020\ - \000000803200743035b00010200000000" - ~: [aesonQQ| - [ { "prim": "RIGHT", "args": [ { "prim": "unit" } ], - "annots": [ ":ru", "%", "%@" ] }, - [ { "prim": "IF_LEFT", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ], - [] ] } ] ] - |] - , "RIGHT :ru % %@ @vr unit; IF_RIGHT {} { DROP; PUSH int 1 }" - ~: "0x05020000002d0644036c0000000c3a72752025202540204076720200000014072e020\ - \000000803200743035b00010200000000" - ~: [aesonQQ| - [ { "prim": "RIGHT", "args": [ { "prim": "unit" } ], - "annots": [ ":ru", "%", "%@", "@vr" ] }, - [ { "prim": "IF_LEFT", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ], - [] ] } ] ] - |] - , "DUP; NIL int; SWAP; CONS; SIZE; DROP" - ~: "0x05020000000e0321053d035b034c031b03450320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "NIL", "args": [ { "prim": "int" } ] }, - { "prim": "SWAP" }, { "prim": "CONS" }, { "prim": "SIZE" }, - { "prim": "DROP" } ] - |] - , "NIL int; IF_CONS { DROP; DROP } {}" - ~: "0x050200000014053d035b072d0200000004032003200200000000" - ~: [aesonQQ| - [ { "prim": "NIL", "args": [ { "prim": "int" } ] }, - { "prim": "IF_CONS", - "args": [ [ { "prim": "DROP" }, { "prim": "DROP" } ], [] ] } ] - |] - , "NIL :ni int; IF_CONS { DROP; DROP } {}" - ~: "0x05020000001b063d035b000000033a6e69072d0200000004032003200200000000" - ~: [aesonQQ| - [ { "prim": "NIL", "args": [ { "prim": "int" } ], "annots": [ ":ni" ] }, - { "prim": "IF_CONS", - "args": [ [ { "prim": "DROP" }, { "prim": "DROP" } ], [] ] } ] - |] - , "EMPTY_SET int; ITER { DROP }" - ~: "0x05020000000d0524035b055202000000020320" - ~: [aesonQQ| - [ { "prim": "EMPTY_SET", "args": [ { "prim": "int" } ] }, - { "prim": "ITER", "args": [ [ { "prim": "DROP" } ] ] } ] - |] - , "EMPTY_SET :si int; ITER { DROP }" - ~: "0x0502000000140624035b000000033a7369055202000000020320" - ~: [aesonQQ| - [ { "prim": "EMPTY_SET", "args": [ { "prim": "int" } ], "annots": [ ":si" ] }, - { "prim": "ITER", "args": [ [ { "prim": "DROP" } ] ] } ] - |] - , "EMPTY_MAP int unit; MAP {}; DROP" - ~: "0x05020000000f0723035b036c053802000000000320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "MAP", "args": [ [] ] }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP :miu int unit; MAP {}; DROP" - ~: "0x0502000000170823035b036c000000043a6d6975053802000000000320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ], - "annots": [ ":miu" ] }, { "prim": "MAP", "args": [ [] ] }, - { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; PUSH int 1; MEM; DROP" - ~: "0x0502000000100723035b036c0743035b000103390320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "MEM" }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; PUSH int 1; GET; DROP" - ~: "0x0502000000100723035b036c0743035b000103290320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET" }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; NONE unit; PUSH int 1; UPDATE; DROP" - ~: "0x0502000000140723035b036c053e036c0743035b000103500320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "NONE", "args": [ { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "UPDATE" }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; NONE unit; PUSH int 1; GET_AND_UPDATE; DROP 2" - ~: "0x0502000000160723035b036c053e036c0743035b0001038c05200002" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "NONE", "args": [ { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET_AND_UPDATE" }, - { "prim": "DROP", "args": [ { "int": "2" } ] } ] - |] - , "EMPTY_BIG_MAP int unit; PUSH int 1; GET; DROP" - ~: "0x0502000000100772035b036c0743035b000103290320" - ~: [aesonQQ| - [ { "prim": "EMPTY_BIG_MAP", - "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET" }, { "prim": "DROP" } ] - |] - , "EMPTY_BIG_MAP :bmiu int unit; PUSH int 1; GET; DROP" - ~: "0x0502000000190872035b036c000000053a626d69750743035b000103290320" - ~: [aesonQQ| - [ { "prim": "EMPTY_BIG_MAP", - "args": [ { "prim": "int" }, { "prim": "unit" } ], - "annots": [ ":bmiu" ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PAIR; GET 1;" - ~: "0x05020000000c0743035b0001034205290001" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR" }, { "prim": "GET", "args": [ { "int": "1" } ] } ] - |] - , "DUP; UPDATE 0;" - ~: "0x050200000006032105500000" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "UPDATE", "args": [ { "int": "0" } ] } ] - |] - , "PUSH bool True; IF {} {}" - ~: "0x05020000001207430359030a072c02000000000200000000" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bool" }, { "prim": "True" } ] }, - { "prim": "IF", "args": [ [], [] ] } ] - |] - , "PUSH bool True; LOOP { PUSH bool False }" - ~: "0x05020000001307430359030a05340200000006074303590303" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bool" }, { "prim": "True" } ] }, - { "prim": "LOOP", - "args": - [ [ { "prim": "PUSH", - "args": [ { "prim": "bool" }, { "prim": "False" } ] } ] ] } ] - |] - , "PUSH (or int int) (Left 1); LOOP_LEFT { RIGHT int }; DROP" - ~: "0x05020000001907430764035b035b05050001055302000000040544035b0320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "or", "args": [ { "prim": "int" }, { "prim": "int" } ] }, - { "prim": "Left", "args": [ { "int": "1" } ] } ] }, - { "prim": "LOOP_LEFT", - "args": [ [ { "prim": "RIGHT", "args": [ { "prim": "int" } ] } ] ] }, - { "prim": "DROP" } ] - |] - , "LAMBDA int int { PUSH int 1; DROP }; SWAP; EXEC" - ~: "0x05020000001f093100000011035b035b02000000080743035b0001032000000000034c0326" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "int" }, { "prim": "int" }, - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "DROP" } ] ] }, { "prim": "SWAP" }, { "prim": "EXEC" } ] - |] - , "DUP; LAMBDA (pair int int) int { CAR }; SWAP; APPLY; SWAP; EXEC" - ~: "0x050200000023032109310000000f0765035b035b035b0200000002031600000000034c0373\ - \034c0326" - ~: [aesonQQ| - [ { "prim": "DUP" }, - { "prim": "LAMBDA", - "args": - [ { "prim": "pair", "args": [ { "prim": "int" }, { "prim": "int" } ] }, - { "prim": "int" }, [ { "prim": "CAR" } ] ] }, { "prim": "SWAP" }, - { "prim": "APPLY" }, { "prim": "SWAP" }, { "prim": "EXEC" } ] - |] - , "DIP {}" - ~: "0x050200000007051f0200000000" - ~: [aesonQQ| - [ { "prim": "DIP", "args": [ [] ] } ] - |] - , "DIP 1 {}" - ~: "0x050200000009071f00010200000000" - ~: [aesonQQ| - [ { "prim": "DIP", "args": [ { "int": "1" }, [] ] } ] - |] - , "DIP 0 {}" - ~: "0x050200000009071f00000200000000" - ~: [aesonQQ| - [ { "prim": "DIP", "args": [ { "int": "0" }, [] ] } ] - |] - , "UNIT; UNIT; DIP 3 { UNIT; DROP }; DROP; DROP" - ~: "0x050200000015034f034f071f00030200000004034f032003200320" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "UNIT" }, - { "prim": "DIP", - "args": [ { "int": "3" }, [ { "prim": "UNIT" }, { "prim": "DROP" } ] ] }, - { "prim": "DROP" }, { "prim": "DROP" } ] - |] - , "UNIT; UNIT; DIIIP { UNIT; DROP }; DROP; DROP" - ~: "0x050200000015034f034f071f00030200000004034f032003200320" - ~: [aesonQQ| - [ { "prim": "UNIT" }, { "prim": "UNIT" }, - { "prim": "DIP", - "args": [ { "int": "3" }, [ { "prim": "UNIT" }, { "prim": "DROP" } ] ] }, - { "prim": "DROP" }, { "prim": "DROP" } ] - |] - , "FAILWITH" - ~: "0x0502000000020327" - ~: [aesonQQ| - [ { "prim": "FAILWITH" } ] - |] - , "CAST int" - ~: "0x0502000000040557035b" - ~: [aesonQQ| - [ { "prim": "CAST", "args": [ { "prim": "int" } ] } ] - |] - , "RENAME" - ~: "0x0502000000020358" - ~: [aesonQQ| - [ { "prim": "RENAME" } ] - |] - , "DUP; PACK; UNPACK unit; DROP" - ~: "0x05020000000a0321030c050d036c0320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "PACK" }, - { "prim": "UNPACK", "args": [ { "prim": "unit" } ] }, { "prim": "DROP" } ] - |] - , "DUP; PACK; UNPACK :uu unit; DROP" - ~: "0x0502000000110321030c060d036c000000033a75750320" - ~: [aesonQQ| - [ { "prim": "DUP" }, { "prim": "PACK" }, - { "prim": "UNPACK", "args": [ { "prim": "unit" } ], "annots": [ ":uu" ] }, - { "prim": "DROP" } ] - |] - , "PUSH string \"\"; DUP; CONCAT; DROP" - ~: "0x05020000000f0743036801000000000321031a0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "" } ] }, - { "prim": "DUP" }, { "prim": "CONCAT" }, { "prim": "DROP" } ] - |] - , "NIL string; CONCAT; DROP" - ~: "0x050200000008053d0368031a0320" - ~: [aesonQQ| - [ { "prim": "NIL", "args": [ { "prim": "string" } ] }, { "prim": "CONCAT" }, - { "prim": "DROP" } ] - |] - , "PUSH string \"\"; PUSH nat 1; PUSH nat 2; SLICE; DROP" - ~: "0x050200000019074303680100000000074303620001074303620002036f0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "SLICE" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; ISNAT; DROP" - ~: "0x05020000000a0743035b000103560320" - -- Arithmetic instructions are below - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "ISNAT" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; INT; DROP" - ~: "0x05020000000a07430362000103300320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "INT" }, { "prim": "DROP" } ] - |] - , "VIEW \"myview\" nat" - ~: "0x05020000000f079001000000066d79766965770362" - ~: [aesonQQ| - [ { "prim": "VIEW", "args": [ { "string": "myview" }, { "prim": "nat" } ] } ] - |] - -- SELF cannot appear in lambda - -- CONTRACT - IMPLICIT_ACCOUNT go below - , "NOW; DROP" - ~: "0x05020000000403400320" - ~: [aesonQQ| - [ { "prim": "NOW" }, { "prim": "DROP" } ] - |] - , "AMOUNT; DROP" - ~: "0x05020000000403130320" - ~: [aesonQQ| - [ { "prim": "AMOUNT" }, { "prim": "DROP" } ] - |] - , "BALANCE; DROP" - ~: "0x05020000000403150320" - ~: [aesonQQ| - [ { "prim": "BALANCE" }, { "prim": "DROP" } ] - |] - -- VOTING_POWER goes below - , "TOTAL_VOTING_POWER; DROP" - ~: "0x050200000004037c0320" - ~: [aesonQQ| - [ { "prim": "TOTAL_VOTING_POWER" }, { "prim": "DROP" } ] - |] - -- CHECK_SIGNATURE goes below - , "PUSH bytes 0x; SHA256; DROP" - ~: "0x05020000000d074303690a00000000030f0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "SHA256" }, { "prim": "DROP" } ] - |] - , "PUSH bytes 0x; SHA512; DROP" - ~: "0x05020000000d074303690a0000000003100320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "SHA512" }, { "prim": "DROP" } ] - |] - , "PUSH bytes 0x; BLAKE2B; DROP" - ~: "0x05020000000d074303690a00000000030e0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "BLAKE2B" }, { "prim": "DROP" } ] - |] - , "PUSH bytes 0x; SHA3; DROP" - ~: "0x05020000000d074303690a00000000037e0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "SHA3" }, { "prim": "DROP" } ] - |] - , "PUSH bytes 0x; KECCAK; DROP" - ~: "0x05020000000d074303690a00000000037d0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "KECCAK" }, { "prim": "DROP" } ] - |] - , "PUSH (list (pair bls12_381_g1 bls12_381_g2)) {}; PAIRING_CHECK; DROP" - ~: "0x0502000000130743055f0765038003810200000000037f0320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "list", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "bls12_381_g1" }, - { "prim": "bls12_381_g2" } ] } ] }, - [] ] }, { "prim": "PAIRING_CHECK" }, { "prim": "DROP" } ] - |] - -- HASH_KEY goes below - , "SOURCE; DROP" - ~: "0x05020000000403470320" - ~: [aesonQQ| - [ { "prim": "SOURCE" }, { "prim": "DROP" } ] - |] - , "SENDER; DROP" - ~: "0x05020000000403480320" - ~: [aesonQQ| - [ { "prim": "SENDER" }, { "prim": "DROP" } ] - |] - -- ADDRESS goes below - , "CHAIN_ID; DROP" - ~: "0x05020000000403750320" - ~: [aesonQQ| - [ { "prim": "CHAIN_ID" }, { "prim": "DROP" } ] - |] - , "LEVEL; DROP" - ~: "0x05020000000403760320" - ~: [aesonQQ| [ { "prim": "LEVEL" }, { "prim": "DROP" } ] |] - , "SELF_ADDRESS; DROP" - ~: "0x05020000000403770320" - ~: [aesonQQ| [ { "prim": "SELF_ADDRESS" }, { "prim": "DROP" } ] |] - , "PUSH nat 5; PUSH nat 5; TICKET; DROP" - ~: "0x05020000001007430362000507430362000503880320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "5" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "5" } ] }, - { "prim": "TICKET" }, { "prim": "DROP" } ] - |] - -- other ticket-related instructions go below - - -- DUP macro - , "PUSH nat 1; PUSH nat 1; DUUP; DROP; DROP; DROP" - ~: "0x05020000001607430362000107430362000105210002032003200320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "DUP", "args": [ { "int": "2" } ] }, { "prim": "DROP" }, - { "prim": "DROP" }, { "prim": "DROP" } ] - |] - -- CAR k and CDR k macros - , "PUSH string \"owo\"; PUSH int 2; PAIR 3; CAR 0" - ~: "0x05020000001f0743036801000000036f776f0743035b000205420003020000000405290001" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "owo" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "PAIR", "args": [ { "int": "3" } ] }, - [ { "prim": "GET", "args": [ { "int": "1" } ] } ] ] - |] - , "PUSH string \"owo\"; PUSH nat 2; PAIR 3; CDR 0; CDR 2" - ~: "0x0502000000280743036801000000036f776f07430362000205420003020000000405290000020000000405290004" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "owo" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "PAIR", "args": [ { "int": "3" } ] }, - [ { "prim": "GET", "args": [ { "int": "0" } ] } ], - [ { "prim": "GET", "args": [ { "int": "4" } ] } ] ] - |] - , "DUP @dp; SWAP; DROP" - ~: "0x05020000000d042100000003406470034c0320" - ~: [aesonQQ| - [ { "prim": "DUP", "annots": [ "@dp" ] }, { "prim": "SWAP" }, - { "prim": "DROP" } ] - |] - , "DUP @y 1; SWAP; DROP" - ~: "0x05020000000e06210001000000024079034c0320" - ~: [aesonQQ| - [ { "prim": "DUP", "args": [ { "int": "1" } ], "annots": [ "@y" ] }, - { "prim": "SWAP" }, { "prim": "DROP" } ] - |] - , "UNIT @un; DROP" - ~: "0x05020000000b044f0000000340756e0320" - ~: [aesonQQ| - [ { "prim": "UNIT", "annots": [ "@un" ] }, { "prim": "DROP" } ] - |] - , "NONE @nn int; DROP" - ~: "0x05020000000d063e035b00000003406e6e0320" - ~: [aesonQQ| - [ { "prim": "NONE", "args": [ { "prim": "int" } ], "annots": [ "@nn" ] }, - { "prim": "DROP" } ] - |] - , "PUSH @vn int 1; PAIR @vpn; CAR @vn" - ~: "0x0502000000200843035b00010000000340766e0442000000044076706e0416\ - \0000000340766e" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ], - "annots": [ "@vn" ] }, { "prim": "PAIR", "annots": [ "@vpn" ] }, - { "prim": "CAR", "annots": [ "@vn" ] } ] - |] - , "PUSH int 1; PAIR @ 2; CAR" - ~: "0x05020000000c0743035b0001054200020316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "args": [ { "int": "2" } ] }, { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR @x 2; CAR" - ~: "0x0502000000120743035b0001064200020000000240780316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "args": [ { "int": "2" } ], "annots": [ "@x" ] }, - { "prim": "CAR" } ] - |] - , "PUSH @a int 1; PAIR @x 2; CAR" - ~: "0x0502000000180843035b0001000000024061064200020000000240780316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ], - "annots": [ "@a" ] }, - { "prim": "PAIR", "args": [ { "int": "2" } ], "annots": [ "@x" ] }, - { "prim": "CAR" } ] - |] - , "PUSH nat 1; PUSH bool True; PUSH int 1; PAIR @x 4; CAR" - ~: "0x05020000001e07430362000107430359030a0743035b0001064200040000000240780316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "bool" }, { "prim": "True" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR", "args": [ { "int": "4" } ], "annots": [ "@x" ] }, - { "prim": "CAR" } ] - |] - , "PUSH @a nat 1; PUSH @b bool True; PUSH @c int 1; PAIR @x 4; CAR" - ~: "0x05020000003008430362000100000002406108430359030a0000000240620843035b0001000000024063064200040000000240780316" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ], - "annots": [ "@a" ] }, - { "prim": "PUSH", "args": [ { "prim": "bool" }, { "prim": "True" } ], - "annots": [ "@b" ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ], - "annots": [ "@c" ] }, - { "prim": "PAIR", "args": [ { "int": "4" } ], "annots": [ "@x" ] }, - { "prim": "CAR" } ] - |] - , "PUSH int 1; PAIR; CDR @dr" - ~: "0x0502000000110743035b00010342041700000003406472" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR" }, { "prim": "CDR", "annots": [ "@dr" ] } ] - |] - , "LEFT @ll unit; IF_LEFT {} { DROP; PUSH int 1 }" - ~: "0x05020000001f0633036c00000003406c6c072e020000000002000000080320\ - \0743035b0001" - ~: [aesonQQ| - [ { "prim": "LEFT", "args": [ { "prim": "unit" } ], "annots": [ "@ll" ] }, - { "prim": "IF_LEFT", - "args": - [ [], - [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ] ] } ] - |] - , "RIGHT @rl unit; IF_RIGHT {} { DROP; PUSH int 1 }" - ~: "0x0502000000240644036c0000000340726c0200000014072e02000000080320\ - \0743035b00010200000000" - ~: [aesonQQ| - [ { "prim": "RIGHT", "args": [ { "prim": "unit" } ], "annots": [ "@rl" ] }, - [ { "prim": "IF_LEFT", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] } ], - [] ] } ] ] - |] - , "DUP; NIL @al int; SWAP; CONS @dl; SIZE @sl; DROP" - ~: "0x0502000000230321063d035b0000000340616c034c041b0000000340646c04\ - \450000000340736c0320" - ~: [aesonQQ| - [ { "prim": "DUP" }, - { "prim": "NIL", "args": [ { "prim": "int" } ], "annots": [ "@al" ] }, - { "prim": "SWAP" }, { "prim": "CONS", "annots": [ "@dl" ] }, - { "prim": "SIZE", "annots": [ "@sl" ] }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP @sm int unit; PUSH int 1; MEM @mmm; DROP" - ~: "0x05020000001f0823035b036c0000000340736d0743035b0001043900000004406d6d6d0320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ], - "annots": [ "@sm" ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "MEM", "annots": [ "@mmm" ] }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; NONE unit; PUSH int 1; UPDATE @ups; DROP" - ~: "0x05020000001c0723035b036c053e036c0743035b0001045000000004407570730320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "NONE", "args": [ { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "UPDATE", "annots": [ "@ups" ] }, { "prim": "DROP" } ] - |] - , "EMPTY_MAP int unit; NONE unit; PUSH int 1; GET_AND_UPDATE @ups; DROP 2" - ~: "0x05020000001e0723035b036c053e036c0743035b0001048c000000044075707305200002" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "NONE", "args": [ { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET_AND_UPDATE", "annots": [ "@ups" ] }, - { "prim": "DROP", "args": [ { "int": "2" } ] } ] - |] - , "EMPTY_BIG_MAP int unit; PUSH int 1; GET @gg; DROP" - ~: "0x0502000000170772035b036c0743035b00010429000000034067670320" - ~: [aesonQQ| - [ { "prim": "EMPTY_BIG_MAP", - "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GET", "annots": [ "@gg" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PAIR; GET @gg 1;" - ~: "0x0502000000130743035b000103420629000100000003406767" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PAIR" }, - { "prim": "GET", "args": [ { "int": "1" } ], "annots": [ "@gg" ] } ] - |] - , "DUP; UPDATE @gg 0;" - ~: "0x05020000000d03210650000000000003406767" - ~: [aesonQQ| - [ { "prim": "DUP" }, - { "prim": "UPDATE", "args": [ { "int": "0" } ], "annots": [ "@gg" ] } ] - |] - , "PUSH string \"\"; DUP; CONCAT @c; DROP" - ~: "0x0502000000150743036801000000000321041a0000000240630320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "" } ] }, - { "prim": "DUP" }, { "prim": "CONCAT", "annots": [ "@c" ] }, - { "prim": "DROP" } ] - |] - , "PUSH int 1; PUSH int 2; ADD @a; DROP" - ~: "0x0502000000160743035b00010743035b000204120000000240610320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "ADD", "annots": [ "@a" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PUSH int 2; SUB @s; DROP" - ~: "0x0502000000160743035b00010743035b0002044b0000000240730320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "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| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "MUL", "annots": [ "@m" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PUSH int 2; EDIV @edv; DROP" - ~: "0x0502000000180743035b00010743035b0002042200000004406564760320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "EDIV", "annots": [ "@edv" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; ABS @a; DROP" - ~: "0x0502000000100743035b000104110000000240610320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "ABS", "annots": [ "@a" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NEG @n; DROP" - ~: "0x0502000000100743035b0001043b00000002406e0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NEG", "annots": [ "@n" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; LSL @ll; DROP" - ~: "0x050200000017074303620001074303620002043500000003406c6c0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "LSL", "annots": [ "@ll" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; LSR @lr; DROP" - ~: "0x050200000017074303620001074303620002043600000003406c720320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "LSR", "annots": [ "@lr" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; OR @o; DROP" - ~: "0x050200000016074303620001074303620002044100000002406f0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "OR", "annots": [ "@o" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; XOR @x; DROP" - ~: "0x05020000001607430362000107430362000204510000000240780320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "XOR", "annots": [ "@x" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NOT @n; DROP" - ~: "0x0502000000100743035b0001043f00000002406e0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NOT", "annots": [ "@n" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; COMPARE @cp; DROP" - ~: "0x0502000000170743036200010743036200020419000000034063700320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "COMPARE", "annots": [ "@cp" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; EQ @e; DROP" - ~: "0x0502000000100743035b000104250000000240650320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "EQ", "annots": [ "@e" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NEQ @ne; DROP" - ~: "0x0502000000110743035b0001043c00000003406e650320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NEQ", "annots": [ "@ne" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; LT @l; DROP" - ~: "0x0502000000100743035b0001043700000002406c0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "LT", "annots": [ "@l" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; GT @g; DROP" - ~: "0x0502000000100743035b0001042a0000000240670320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GT", "annots": [ "@g" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; LE @e; DROP" - ~: "0x0502000000100743035b000104320000000240650320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "LE", "annots": [ "@e" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; GE @g; DROP" - ~: "0x0502000000100743035b000104280000000240670320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GE", "annots": [ "@g" ] }, { "prim": "DROP" } ] - |] - , "PUSH int 1; ISNAT @i; DROP" - ~: "0x0502000000100743035b000104560000000240690320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "ISNAT", "annots": [ "@i" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; INT @i; DROP" - ~: "0x05020000001007430362000104300000000240690320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "INT", "annots": [ "@i" ] }, { "prim": "DROP" } ] - |] - , "NOW @n; DROP" - ~: "0x05020000000a044000000002406e0320" - ~: [aesonQQ| - [ { "prim": "NOW", "annots": [ "@n" ] }, { "prim": "DROP" } ] - |] - , "LEVEL @n; DROP" - ~: "0x05020000000a047600000002406e0320" - ~: [aesonQQ| - [ { "prim": "LEVEL", "annots": [ "@n" ] }, { "prim": "DROP" } ] - |] - , "SELF_ADDRESS @n; DROP" - ~: "0x05020000000a047700000002406e0320" - ~: [aesonQQ| - [ { "prim": "SELF_ADDRESS", "annots": [ "@n" ] }, { "prim": "DROP" } ] - |] - , "AMOUNT @a; DROP" - ~: "0x05020000000a04130000000240610320" - ~: [aesonQQ| - [ { "prim": "AMOUNT", "annots": [ "@a" ] }, { "prim": "DROP" } ] - |] - , "BALANCE @b; DROP" - ~: "0x05020000000a04150000000240620320" - ~: [aesonQQ| - [ { "prim": "BALANCE", "annots": [ "@b" ] }, { "prim": "DROP" } ] - |] - , "TOTAL_VOTING_POWER @vp; DROP" - ~: "0x05020000000b047c000000034076700320" - ~: [aesonQQ| - [ { "prim": "TOTAL_VOTING_POWER", "annots": [ "@vp" ] }, - { "prim": "DROP" } ] - |] - , "PUSH key_hash 0x001e45d2f8e24d7c39b15daa2fb3b5fac470818eb6; VOTING_POWER @vp; DROP" - ~: "0x0502000000290743035d0a00000015001e45d2f8e24d7c39b15daa2fb3b5fac470818eb6047b000000034076700320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "key_hash" }, - { "bytes": "001e45d2f8e24d7c39b15daa2fb3b5fac470818eb6" } ] }, - { "prim": "VOTING_POWER", "annots": [ "@vp" ] }, { "prim": "DROP" } ] - |] - , "PUSH bytes 0x; BLAKE2B @b2b; DROP" - ~: "0x050200000015074303690a00000000040e00000004406232620320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "bytes" }, { "bytes": "" } ] }, - { "prim": "BLAKE2B", "annots": [ "@b2b" ] }, { "prim": "DROP" } ] - |] - , "SOURCE @src; DROP" - ~: "0x05020000000c044700000004407372630320" - ~: [aesonQQ| - [ { "prim": "SOURCE", "annots": [ "@src" ] }, { "prim": "DROP" } ] - |] - , "SENDER @s; DROP" - ~: "0x05020000000a04480000000240730320" - ~: [aesonQQ| - [ { "prim": "SENDER", "annots": [ "@s" ] }, { "prim": "DROP" } ] - |] - , "CHAIN_ID @cid; DROP" - ~: "0x05020000000c047500000004406369640320" - ~: [aesonQQ| - [ { "prim": "CHAIN_ID", "annots": [ "@cid" ] }, { "prim": "DROP" } ] - |] - , "CAST @c int" - ~: "0x05020000000a0657035b000000024063" - ~: [aesonQQ| - [ { "prim": "CAST", "args": [ { "prim": "int" } ], "annots": [ "@c" ] } ] - |] - , "CAST @c (int :i)" - ~: "0x0502000000100657045b000000023a69000000024063" - ~: [aesonQQ| - [ { "prim": "CAST", "args": [ { "prim": "int", "annots": [ ":i" ] } ], - "annots": [ "@c" ] } ] - |] - , "CAST (int :i)" - ~: "0x05020000000a0557045b000000023a69" - ~: [aesonQQ| - [ { "prim": "CAST", "args": [ { "prim": "int", "annots": [ ":i" ] } ] } ] - |] - , "RENAME @r" - ~: "0x0502000000080458000000024072" - ~: [aesonQQ| - [ { "prim": "RENAME", "annots": [ "@r" ] } ] - |] - , "PUSH string \"owo\"; PUSH int 2; PAIR 3; CAR @kek 0" - ~: "0x0502000000270743036801000000036f776f0743035b000205420003020000000c0629000100000004406b656b" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "owo" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "PAIR", "args": [ { "int": "3" } ] }, - [ { "prim": "GET", "args": [ { "int": "1" } ], "annots": [ "@kek" ] } ] ] - |] - , "PUSH string \"owo\"; PUSH nat 2; PAIR 3; CDR @foo 0; CDR @bar 2" - ~: "0x0502000000380743036801000000036f776f07430362000205420003020000000c062900000000000440666f6f020000000c062900040000000440626172" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "string" }, { "string": "owo" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "PAIR", "args": [ { "int": "3" } ] }, - [ { "prim": "GET", "args": [ { "int": "0" } ], "annots": [ "@foo" ] } ], - [ { "prim": "GET", "args": [ { "int": "4" } ], "annots": [ "@bar" ] } ] ] - |] - , "EMPTY_SET :si @si int; ITER { DROP }" - ~: "0x0502000000180624035b000000073a736920407369055202000000020320" - ~: [aesonQQ| - [ { "prim": "EMPTY_SET", "args": [ { "prim": "int" } ], - "annots": [ ":si", "@si" ] }, - { "prim": "ITER", "args": [ [ { "prim": "DROP" } ] ] } ] - |] - , "EMPTY_MAP :miu @em int unit; MAP @dm {}; DROP" - ~: "0x0502000000220823035b036c000000083a6d69752040656d063802000000000000000340646d0320" - ~: [aesonQQ| - [ { "prim": "EMPTY_MAP", "args": [ { "prim": "int" }, { "prim": "unit" } ], - "annots": [ ":miu", "@em" ] }, - { "prim": "MAP", "args": [ [] ], "annots": [ "@dm" ] }, - { "prim": "DROP" } ] - |] - , "DROP; PUSH @i (int :i) 42; DUP 1; SWAP; DROP" - ~: "0x05020000001c03200843045b000000023a69002a00000002406905210001034c0320" - ~: [aesonQQ| - [ { "prim": "DROP" }, - { "prim": "PUSH", - "args": [ { "prim": "int", "annots": [ ":i" ] }, { "int": "42" } ], - "annots": [ "@i" ] }, { "prim": "DUP", "args": [ { "int": "1" } ] }, - { "prim": "SWAP" }, { "prim": "DROP" } ] - |] - , "LAMBDA @lii int int { PUSH int 1; DROP }; SWAP; EXEC" - ~: "0x050200000023093100000011035b035b02000000080743035b000103200000\ - \0004406c6969034c0326" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "int" }, { "prim": "int" }, - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "DROP" } ] ], "annots": [ "@lii" ] }, { "prim": "SWAP" }, - { "prim": "EXEC" } ] - |] - ] - - parseSerializeSpec "arith instr" - [ "PUSH int 1; PUSH int 2; ADD; DROP" - ~: "0x0502000000100743035b00010743035b000203120320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "ADD" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PUSH int 2; SUB; DROP" - ~: "0x0502000000100743035b00010743035b0002034b0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "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| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "MUL" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; PUSH int 2; EDIV; DROP" - ~: "0x0502000000100743035b00010743035b000203220320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] }, - { "prim": "EDIV" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; ABS; DROP" - ~: "0x05020000000a0743035b000103110320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "ABS" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NEG @kek; DROP" - ~: "0x0502000000120743035b0001043b00000004406b656b0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NEG", "annots": [ "@kek" ] }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; LSL; DROP" - ~: "0x05020000001007430362000107430362000203350320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "LSL" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; LSR; DROP" - ~: "0x05020000001007430362000107430362000203360320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "LSR" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; OR; DROP" - ~: "0x05020000001007430362000107430362000203410320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "OR" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; XOR; DROP" - ~: "0x05020000001007430362000107430362000203510320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "XOR" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NOT; DROP" - ~: "0x05020000000a0743035b0001033f0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NOT" }, { "prim": "DROP" } ] - |] - , "PUSH nat 1; PUSH nat 2; COMPARE; DROP" - ~: "0x05020000001007430362000107430362000203190320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "2" } ] }, - { "prim": "COMPARE" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; EQ; DROP" - ~: "0x05020000000a0743035b000103250320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "EQ" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; NEQ; DROP" - ~: "0x05020000000a0743035b0001033c0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "NEQ" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; LT; DROP" - ~: "0x05020000000a0743035b000103370320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "LT" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; GT; DROP" - ~: "0x05020000000a0743035b0001032a0320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GT" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; LE; DROP" - ~: "0x05020000000a0743035b000103320320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "LE" }, { "prim": "DROP" } ] - |] - , "PUSH int 1; GE; DROP" - ~: "0x05020000000a0743035b000103280320" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "GE" }, { "prim": "DROP" } ] - |] - ] - - parseSerializeSpec "instrs address-related" - [ "CONTRACT unit; DROP; PUSH unit Unit" - ~: "0x05020000000c0555036c03200743036c030b" - ~: [aesonQQ| - [ { "prim": "CONTRACT", "args": [ { "prim": "unit" } ] }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "CONTRACT %entrypnt unit; DROP; PUSH unit Unit" - ~: "0x0502000000190655036c0000000925656e747279706e7403200743036c030b" - ~: [aesonQQ| - [ { "prim": "CONTRACT", "args": [ { "prim": "unit" } ], - "annots": [ "%entrypnt" ] }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "CONTRACT @va %entrypnt unit; DROP; PUSH unit Unit" - ~: "0x05020000001d0655036c0000000d25656e747279706e742040766103200743036c030b" - ~: [aesonQQ| - [ { "prim": "CONTRACT", "args": [ { "prim": "unit" } ], - "annots": [ "%entrypnt", "@va" ] }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "CONTRACT @va unit; DROP; PUSH unit Unit" - ~: "0x0502000000130655036c0000000340766103200743036c030b" - ~: [aesonQQ| - [ { "prim": "CONTRACT", "args": [ { "prim": "unit" } ], "annots": [ "@va" ] }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - ] - - parseSerializeSpec "instrs contract-related" - [ "PUSH mutez 5; PUSH unit Unit; TRANSFER_TOKENS; DROP; PUSH unit Unit" - ~: "0x0502000000160743036a00050743036c030b034d03200743036c030b" - ~: [aesonQQ| - [ { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] }, - { "prim": "TRANSFER_TOKENS" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "ADDRESS; DROP; PUSH unit Unit" - ~: "0x05020000000a035403200743036c030b" - ~: [aesonQQ| - [ { "prim": "ADDRESS" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - ] - - parseSerializeSpec "instrs key-hash-related" - [ "SOME; SET_DELEGATE; DROP; PUSH unit Unit" - ~: "0x05020000000c0346034e03200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, { "prim": "SET_DELEGATE" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "SOME; DIP{ PUSH unit Unit; PUSH mutez 5; }; \ - \ CREATE_CONTRACT{ \ - \ storage unit; \ - \ parameter unit; \ - \ code { DROP; UNIT; NIL operation; PAIR } \ - \ }; \ - \ DROP; DROP; PUSH unit Unit \ - \" - ~: "0x05020000003f0346051f020000000c0743036c030b0743036a0005051d020000\ - \00190501036c0500036c0502020000000a0320034f053d036d0342032003200743\ - \036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, - { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", - "args": [ { "prim": "unit" }, { "prim": "Unit" } ] }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] } ] ] }, - { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "parameter", "args": [ { "prim": "unit" } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, { "prim": "UNIT" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] ] }, { "prim": "DROP" }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \ - \ CREATE_CONTRACT{ \ - \ parameter (int :p); \ - \ storage (int :s); \ - \ code { DROP; PUSH int 10; NIL operation; PAIR } \ - \ }; \ - \ DROP; DROP; PUSH unit Unit \ - \" - ~: "0x05020000004f0346051f020000000c0743035b00010743036a0005051d020000\ - \00290500045b000000023a700501045b000000023a730502020000000e03200743\ - \035b000a053d036d0342032003200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, - { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] } ] ] }, - { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "parameter", - "args": [ { "prim": "int", "annots": [ ":p" ] } ] }, - { "prim": "storage", - "args": [ { "prim": "int", "annots": [ ":s" ] } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", - "args": [ { "prim": "int" }, { "int": "10" } ] }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] ] }, { "prim": "DROP" }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \ - \ CREATE_CONTRACT{ \ - \ parameter (int %root :p); \ - \ storage (int :s); \ - \ code { DROP; PUSH int 10; NIL operation; PAIR } \ - \ }; \ - \ DROP; DROP; PUSH unit Unit \ - \" - ~: "0502000000550346051f020000000c0743035b00010743036a0005051d020000002\ - \f0500045b0000000825726f6f74203a700501045b000000023a730502020000000e\ - \03200743035b000a053d036d0342032003200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, - { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] } ] ] }, - { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "parameter", - "args": [ { "prim": "int", "annots": [ "%root", ":p" ] } ] }, - { "prim": "storage", - "args": [ { "prim": "int", "annots": [ ":s" ] } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", - "args": [ { "prim": "int" }, { "int": "10" } ] }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] ] }, { "prim": "DROP" }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "IMPLICIT_ACCOUNT; DROP; PUSH unit Unit" - ~: "0x05020000000a031e03200743036c030b" - ~: [aesonQQ| - [ { "prim": "IMPLICIT_ACCOUNT" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "VOTING_POWER; DROP; UNIT" - ~: "0x050200000006037b0320034f" - ~: [aesonQQ| - [ { "prim": "VOTING_POWER" }, { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - - parseSerializeSpec "instrs public-key-related" - [ "HASH_KEY" - ~: "0x050200000002032b" - ~: [aesonQQ| - [ { "prim": "HASH_KEY" } ] - |] - ] - - parseSerializeSpec "instrs public-key-related" - [ "DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE" - ~: "0x05020000001f051f0200000009074303690a000000000321051f020000\ - \0002031603170318" - ~: [aesonQQ| - [ { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", - "args": [ { "prim": "bytes" }, { "bytes": "" } ] } ] ] }, - { "prim": "DUP" }, { "prim": "DIP", "args": [ [ { "prim": "CAR" } ] ] }, - { "prim": "CDR" }, { "prim": "CHECK_SIGNATURE" } ] - |] - ] - - parseSerializeSpec "instr" - [ "NEVER" - ~: "0x0502000000020379" - ~: [aesonQQ| - [ {"prim": "NEVER"} ] - |] - ] - - parseSerializeSpec "VarAnn instrs address-related" - [ "CONTRACT @c unit; DROP; PUSH unit Unit" - ~: "0x0502000000120655036c00000002406303200743036c030b" - ~: [aesonQQ| - [ { "prim": "CONTRACT", "args": [ { "prim": "unit" } ], "annots": [ "@c" ] }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - ] - - parseSerializeSpec "VarAnn instrs contract-related" - [ "ADDRESS @a; DROP; PUSH unit Unit" - ~: "0x050200000010045400000002406103200743036c030b" - ~: [aesonQQ| - [ { "prim": "ADDRESS", "annots": [ "@a" ] }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - ] - - parseSerializeSpec "VarAnn instrs key-hash-related" - [ "SOME; SET_DELEGATE @d; DROP; PUSH unit Unit" - ~: "0x0502000000120346044e00000002406403200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, { "prim": "SET_DELEGATE", "annots": [ "@d" ] }, - { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \ - \ CREATE_CONTRACT @ez { \ - \ storage (int :s); \ - \ parameter (int :p); \ - \ code { DROP; PUSH int 10; NIL operation; PAIR } \ - \ }; \ - \ DROP; DROP; PUSH unit Unit \ - \" - ~: "0x0502000000560346051f020000000c0743035b00010743036a0005061d02000\ - \000290501045b000000023a730500045b000000023a700502020000000e032007\ - \43035b000a053d036d03420000000340657a032003200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, - { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] } ] ] }, - { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "storage", - "args": [ { "prim": "int", "annots": [ ":s" ] } ] }, - { "prim": "parameter", - "args": [ { "prim": "int", "annots": [ ":p" ] } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", - "args": [ { "prim": "int" }, { "int": "10" } ] }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] ], "annots": [ "@ez" ] }, - { "prim": "DROP" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \ - \ CREATE_CONTRACT @ez @pz { \ - \ parameter (int :p); \ - \ storage (int :s); \ - \ code { DROP; PUSH int 10; NIL operation; PAIR } \ - \ }; \ - \ DROP; DROP; PUSH unit Unit \ - \" - ~: "0x05020000005a0346051f020000000c0743035b00010743036a0005061d02000\ - \000290500045b000000023a700501045b000000023a730502020000000e032007\ - \43035b000a053d036d03420000000740657a2040707a032003200743036c030b" - ~: [aesonQQ| - [ { "prim": "SOME" }, - { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "1" } ] }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "5" } ] } ] ] }, - { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "parameter", - "args": [ { "prim": "int", "annots": [ ":p" ] } ] }, - { "prim": "storage", - "args": [ { "prim": "int", "annots": [ ":s" ] } ] }, - { "prim": "code", - "args": - [ [ { "prim": "DROP" }, - { "prim": "PUSH", - "args": [ { "prim": "int" }, { "int": "10" } ] }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "PAIR" } ] ] } ] ], "annots": [ "@ez", "@pz" ] }, - { "prim": "DROP" }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - , "IMPLICIT_ACCOUNT @i; DROP; PUSH unit Unit" - ~: "0x050200000010041e00000002406903200743036c030b" - ~: [aesonQQ| - [ { "prim": "IMPLICIT_ACCOUNT", "annots": [ "@i" ] }, { "prim": "DROP" }, - { "prim": "PUSH", "args": [ { "prim": "unit" }, { "prim": "Unit" } ] } ] - |] - ] - - parseSerializeSpec "VarAnn instrs public-key-related" - [ "HASH_KEY @h" - ~: "0x050200000008042b000000024068" - ~: [aesonQQ| - [ { "prim": "HASH_KEY", "annots": [ "@h" ] } ] - |] - ] - - parseSerializeSpec "VarAnn instrs public-key-related" - [ "DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE @c" - ~: "0x050200000025051f0200000009074303690a000000000321051f0200000002\ - \031603170418000000024063" - ~: [aesonQQ| - [ { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", - "args": [ { "prim": "bytes" }, { "bytes": "" } ] } ] ] }, - { "prim": "DUP" }, { "prim": "DIP", "args": [ [ { "prim": "CAR" } ] ] }, - { "prim": "CDR" }, { "prim": "CHECK_SIGNATURE", "annots": [ "@c" ] } ] - |] - ] - - parseSerializeSpec "instrs ticket-related 1" - [ "READ_TICKET; DROP; DROP; UNIT" - ~: "0x050200000008038903200320034f" - ~: [aesonQQ| - [ { "prim": "READ_TICKET" }, { "prim": "DROP" }, { "prim": "DROP" }, - { "prim": "UNIT" } ] - |] - , "DIP{ PUSH nat 0; DUP; PAIR }; SPLIT_TICKET; DROP; UNIT" - ~: "0x050200000017051f020000000a07430362000003210342038a0320034f" - ~: [aesonQQ| - [ { "prim": "DIP", - "args": - [ [ { "prim": "PUSH", "args": [ { "prim": "nat" }, { "int": "0" } ] }, - { "prim": "DUP" }, { "prim": "PAIR" } ] ] }, - { "prim": "SPLIT_TICKET" }, { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - - parseSerializeSpec "instrs ticket-related 2" - [ "JOIN_TICKETS; DROP; UNIT" - ~: "0x050200000006038b0320034f" - ~: [aesonQQ| - [ { "prim": "JOIN_TICKETS" }, { "prim": "DROP" }, { "prim": "UNIT" }] - |] - ] - - parseSerializeSpec "top-level view" - [ "CREATE_CONTRACT \ - \{ storage unit; \ - \ parameter unit; \ - \ code { FAILWITH }; \ - \ view \"nyan\" int nat { CAR } \ - \ }" - ~: "0x050200000036051d020000002f0501036c0500036c05020200000002032709910\ - \000001401000000046e79616e035b03620200000002031600000000" - ~: [aesonQQ| - [ { "prim": "CREATE_CONTRACT", - "args": - [ [ { "prim": "storage", "args": [ { "prim": "unit" } ] }, - { "prim": "parameter", "args": [ { "prim": "unit" } ] }, - { "prim": "code", "args": [ [ { "prim": "FAILWITH" } ] ] }, - { "prim": "view", - "args": - [ { "string": "nyan" }, { "prim": "int" }, { "prim": "nat" }, - [ { "prim": "CAR" } ] ] } ] ] } ] - |] - - ] - - -typesTest :: Spec -typesTest = do - -- Bytes we compare agains are produced with command - -- tezos-client convert data '{ LAMBDA ($ty) ($ty) {}; DROP }' from michelson to binary / - -- | tr -d '\n' | awk '{ print $45 }' | sed 's/Hash://' - - -- A right-combed pair can be deserialized from two notations (`pair a b c` or `pair a (pair b c)`), - -- but we only serialize it as `pair a b c`. - -- For this reason, this test only checks that `pair a (pair b c)` can be correctly deserialized. - -- Further down, we have more tests that check serialization+deserialization - -- for the `pair a b c` notation. - parseDeserializeOnlySpec "deserialize right comb pair" - [ - lambdaWrap "pair int nat string" - ~: "0x050200000031093100000025096500000006035b0362036800000000096500000006035b03620368000000000200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, { "prim": "string" } ] }, - [] ] }, { "prim": "DROP" } ] - |] - ] - - parseSerializeSpec "types" - [ lambdaWrap "int" - ~: "0x050200000015093100000009035b035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", "args": [ { "prim": "int" }, { "prim": "int" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "int :i" - ~: "0x050200000021093100000015045b000000023a69045b000000023a690200000\ - \000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "int", "annots": [ ":i" ] }, - { "prim": "int", "annots": [ ":i" ] }, [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "nat" - ~: "0x050200000015093100000009036203620200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", "args": [ { "prim": "nat" }, { "prim": "nat" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "string" - ~: "0x050200000015093100000009036803680200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "string" }, { "prim": "string" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "bytes" - ~: "0x050200000015093100000009036903690200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "bytes" }, { "prim": "bytes" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "mutez" - ~: "0x050200000015093100000009036a036a0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "mutez" }, { "prim": "mutez" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "bool" - ~: "0x050200000015093100000009035903590200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "bool" }, { "prim": "bool" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "key_hash" - ~: "0x050200000015093100000009035d035d0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "key_hash" }, { "prim": "key_hash" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "bls12_381_fr" - ~: "0x050200000015093100000009038203820200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "bls12_381_fr" }, { "prim": "bls12_381_fr" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "bls12_381_g1" - ~: "0x050200000015093100000009038003800200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "bls12_381_g1" }, { "prim": "bls12_381_g1" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "bls12_381_g2" - ~: "0x050200000015093100000009038103810200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "bls12_381_g2" }, { "prim": "bls12_381_g2" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "timestamp" - ~: "0x050200000015093100000009036b036b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "timestamp" }, { "prim": "timestamp" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "address" - ~: "0x050200000015093100000009036e036e0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "address" }, { "prim": "address" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "key" - ~: "0x050200000015093100000009035c035c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", "args": [ { "prim": "key" }, { "prim": "key" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "unit" - ~: "0x050200000015093100000009036c036c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "unit" }, { "prim": "unit" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "never" - ~: "0x050200000015093100000009037803780200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "never" }, { "prim": "never" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "signature" - ~: "0x050200000015093100000009036703670200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "signature" }, { "prim": "signature" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "chain_id" - ~: "0x050200000015093100000009037403740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "chain_id" }, { "prim": "chain_id" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "option unit" - ~: "0x05020000001909310000000d0563036c0563036c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "option", "args": [ { "prim": "unit" } ] }, - { "prim": "option", "args": [ { "prim": "unit" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "set int" - ~: "0x05020000001909310000000d0566035b0566035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "set", "args": [ { "prim": "int" } ] }, - { "prim": "set", "args": [ { "prim": "int" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "set :s int" - ~: "0x0502000000250931000000190666035b000000023a730666035b000000023a7\ - \30200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "set", "args": [ { "prim": "int" } ], "annots": [ ":s" ] }, - { "prim": "set", "args": [ { "prim": "int" } ], "annots": [ ":s" ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "set :s (int :i)" - ~: "0x0502000000310931000000250666045b000000023a69000000023a730666045\ - \b000000023a69000000023a730200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "set", "args": [ { "prim": "int", "annots": [ ":i" ] } ], - "annots": [ ":s" ] }, - { "prim": "set", "args": [ { "prim": "int", "annots": [ ":i" ] } ], - "annots": [ ":s" ] }, [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "operation" - ~: "0x050200000015093100000009036d036d0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": [ { "prim": "operation" }, { "prim": "operation" }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "contract unit" - ~: "0x05020000001909310000000d055a036c055a036c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "contract", "args": [ { "prim": "unit" } ] }, - { "prim": "contract", "args": [ { "prim": "unit" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "ticket int" - ~: "0x05020000001909310000000d0587035b0587035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "ticket", "args": [ { "prim": "int" } ] }, - { "prim": "ticket", "args": [ { "prim": "int" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "pair unit int" - ~: "0x05020000001d0931000000110765036c035b0765036c035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", "args": [ { "prim": "unit" }, { "prim": "int" } ] }, - { "prim": "pair", "args": [ { "prim": "unit" }, { "prim": "int" } ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "pair :point (int %x) (int %y)" - ~: "0x05020000004909310000003d0865045b000000022578045b000000022579000\ - \000063a706f696e740865045b000000022578045b000000022579000000063a70\ - \6f696e740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "int", "annots": [ "%y" ] } ], - "annots": [ ":point" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "int", "annots": [ "%y" ] } ], - "annots": [ ":point" ] }, [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "pair :point3d (pair :point (int %x) (int %y)) (int %z)" - ~: "0x05020000007509310000006908650865045b000000022578045b00000002257\ - \9000000063a706f696e74045b00000002257a000000083a706f696e7433640865\ - \0865045b000000022578045b000000022579000000063a706f696e74045b00000\ - \002257a000000083a706f696e7433640200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "int", "annots": [ "%y" ] } ], - "annots": [ ":point" ] }, - { "prim": "int", "annots": [ "%z" ] } ], - "annots": [ ":point3d" ] }, - { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "int", "annots": [ "%y" ] } ], - "annots": [ ":point" ] }, - { "prim": "int", "annots": [ "%z" ] } ], - "annots": [ ":point3d" ] }, [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "or unit int" - ~: "0x05020000001d0931000000110764036c035b0764036c035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "or", "args": [ { "prim": "unit" }, { "prim": "int" } ] }, - { "prim": "or", "args": [ { "prim": "unit" }, { "prim": "int" } ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "or (unit :u %l) (int :i %r)" - ~: "0x0502000000410931000000350764046c000000053a7520256c045b000000053\ - \a692025720764046c000000053a7520256c045b000000053a6920257202000000\ - \00000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "or", - "args": - [ { "prim": "unit", "annots": [ ":u", "%l" ] }, - { "prim": "int", "annots": [ ":i", "%r" ] } ] }, - { "prim": "or", - "args": - [ { "prim": "unit", "annots": [ ":u", "%l" ] }, - { "prim": "int", "annots": [ ":i", "%r" ] } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "lambda unit int" - ~: "0x05020000001d093100000011075e036c035b075e036c035b0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "lambda", - "args": [ { "prim": "unit" }, { "prim": "int" } ] }, - { "prim": "lambda", - "args": [ { "prim": "unit" }, { "prim": "int" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - , lambdaWrap "lambda :l (unit :n) (int :t)" - ~: "0x050200000041093100000035085e046c000000023a6e045b000000023a74000\ - \000023a6c085e046c000000023a6e045b000000023a74000000023a6c02000000\ - \00000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "lambda", - "args": - [ { "prim": "unit", "annots": [ ":n" ] }, - { "prim": "int", "annots": [ ":t" ] } ], "annots": [ ":l" ] }, - { "prim": "lambda", - "args": - [ { "prim": "unit", "annots": [ ":n" ] }, - { "prim": "int", "annots": [ ":t" ] } ], "annots": [ ":l" ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "map int unit" - ~: "0x05020000001d0931000000110760035b036c0760035b036c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "map", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "map", "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "big_map int unit" - ~: "0x05020000001d0931000000110761035b036c0761035b036c0200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "big_map", - "args": [ { "prim": "int" }, { "prim": "unit" } ] }, - { "prim": "big_map", - "args": [ { "prim": "int" }, { "prim": "unit" } ] }, [] ] }, - { "prim": "DROP" } ] - |] - ] - - parseSerializeSpec "types" - [ lambdaWrap "pair unit int string" - ~: "0x050200000031093100000025096500000006036c035b03680000000009650000000\ - \6036c035b0368000000000200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "unit" }, { "prim": "int" }, { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "unit" }, { "prim": "int" }, { "prim": "string" } ] }, - [] ] }, { "prim": "DROP" } ] - |] - , lambdaWrap "pair (pair int nat string) (pair nat string int) string int nat" - ~: "0x050200000071093100000065096500000026096500000006035b036203680000000\ - \009650000000603620368035b000000000368035b0362000000000965000000260965\ - \00000006035b036203680000000009650000000603620368035b000000000368035b0\ - \362000000000200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, - { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "nat" }, { "prim": "string" }, - { "prim": "int" } ] }, - { "prim": "string" }, { "prim": "int" }, - { "prim": "nat" } ] }, - { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, - { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "nat" }, { "prim": "string" }, - { "prim": "int" } ] }, - { "prim": "string" }, { "prim": "int" }, - { "prim": "nat" } ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair int (pair :t int int)" - ~: "0x0502000000310931000000250765035b0865035b035b000000023a740765035b086503\ - \5b035b000000023a740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, - { "prim": "pair", - "args": [ { "prim": "int" }, { "prim": "int" } ], - "annots": [ ":t" ] } ] }, - { "prim": "pair", - "args": - [ { "prim": "int" }, - { "prim": "pair", - "args": [ { "prim": "int" }, { "prim": "int" } ], - "annots": [ ":t" ] } ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair int (string :t)" - ~: "0x05020000002909310000001d0765035b0468000000023a740765035b0468000000023\ - \a740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "string", "annots": [ ":t" ] } ] }, - { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "string", "annots": [ ":t" ] } ] }, - [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair int string (pair :t int string)" - ~: "0x050200000045093100000039096500000010035b03680865035b03680\ - \00000023a7400000000096500000010035b03680865035b03680000000\ - \23a74000000000200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "string" }, - { "prim": "pair", - "args": [ { "prim": "int" }, { "prim": "string" } ], - "annots": [ ":t" ] } ] }, - { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "string" }, - { "prim": "pair", - "args": [ { "prim": "int" }, { "prim": "string" } ], - "annots": [ ":t" ] } ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair :point (pair int nat string) (pair nat string int) string int nat" - ~: "0x05020000007d093100000071096500000026096500000006035b03620368000000000965\ - \0000000603620368035b000000000368035b0362000000063a706f696e7409650000002609\ - \6500000006035b036203680000000009650000000603620368035b000000000368035b0362\ - \000000063a706f696e740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, - { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "nat" }, { "prim": "string" }, - { "prim": "int" } ] }, - { "prim": "string" }, { "prim": "int" }, - { "prim": "nat" } ], "annots": [ ":point" ] }, - { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, { "prim": "nat" }, - { "prim": "string" } ] }, - { "prim": "pair", - "args": - [ { "prim": "nat" }, { "prim": "string" }, - { "prim": "int" } ] }, - { "prim": "string" }, { "prim": "int" }, - { "prim": "nat" } ], "annots": [ ":point" ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair :point (int :a %x) (int :b %y) (string :c %z)" - ~: "0x050200000073093100000067096500000021045b000000053a61202578045b000000053\ - \a622025790468000000053a6320257a000000063a706f696e74096500000021045b00000\ - \0053a61202578045b000000053a622025790468000000053a6320257a000000063a706f69\ - \6e740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point" ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap - "pair :threepoints\ - \ (pair %first :point (int :a %x) (int :b %y) (string :c %z))\ - \ (pair %second :point (int :a %x) (int :b %y) (string :c %z))\ - \ (pair :point %third (int :a %x) (int :b %y) (string :c %z))" - ~: "0x05020000018f0931000001830965000000a9096500000021045b00000005\ - \3a61202578045b000000053a622025790468000000053a6320257a0000000d\ - \3a706f696e7420256669727374096500000021045b000000053a6120257804\ - \5b000000053a622025790468000000053a6320257a0000000e3a706f696e74\ - \20257365636f6e64096500000021045b000000053a61202578045b00000005\ - \3a622025790468000000053a6320257a0000000d3a706f696e742025746869\ - \72640000000c3a7468726565706f696e74730965000000a909650000002104\ - \5b000000053a61202578045b000000053a622025790468000000053a632025\ - \7a0000000d3a706f696e7420256669727374096500000021045b000000053a\ - \61202578045b000000053a622025790468000000053a6320257a0000000e3a\ - \706f696e7420257365636f6e64096500000021045b000000053a6120257804\ - \5b000000053a622025790468000000053a6320257a0000000d3a706f696e74\ - \202574686972640000000c3a7468726565706f696e74730200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%first" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%second" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%third" ] } ], - "annots": [ ":threepoints" ] }, - { "prim": "pair", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%first" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%second" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ ":a", "%x" ] }, - { "prim": "int", "annots": [ ":b", "%y" ] }, - { "prim": "string", "annots": [ ":c", "%z" ] } ], - "annots": [ ":point", "%third" ] } ], - "annots": [ ":threepoints" ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair :point (int %x) (pair (nat %y) (pair %node string int))" - ~: "0x05020000006f09310000006309650000001f045b00000002257804620000000225\ - \7908650368035b00000005256e6f6465000000063a706f696e7409650000001f045b\ - \000000022578046200000002257908650368035b00000005256e6f6465000000063a\ - \706f696e740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "nat", "annots": [ "%y" ] }, - { "prim": "pair", "args": [ { "prim": "string" }, { "prim": "int" } ], - "annots": [ "%node" ] } ], - "annots": [ ":point" ] }, - { "prim": "pair", - "args": - [ { "prim": "int", "annots": [ "%x" ] }, - { "prim": "nat", "annots": [ "%y" ] }, - { "prim": "pair", "args": [ { "prim": "string" }, { "prim": "int" } ], - "annots": [ "%node" ] } ], - "annots": [ ":point" ] }, [] ] }, { "prim": "DROP" } ] - |] - - , lambdaWrap "pair :point int (pair nat (pair %node string (pair int string)))" - ~: "0x050200000063093100000057096500000019035b03620965000000060368035b03680\ - \0000005256e6f6465000000063a706f696e74096500000019035b036209650000000603\ - \68035b036800000005256e6f6465000000063a706f696e740200000000000000000320" - ~: [aesonQQ| - [ { "prim": "LAMBDA", - "args": - [ { "prim": "pair", - "args": - [ { "prim": "int" }, - { "prim": "nat" }, - { "prim": "pair", "args": - [ - { "prim": "string" }, - { "prim": "int" }, - { "prim": "string" } - ], - "annots": [ "%node" ] } ], - "annots": [ ":point" ] }, - { "prim": "pair", - "args": - [ { "prim": "int" }, - { "prim": "nat" }, - { "prim": "pair", "args": - [ - { "prim": "string" }, - { "prim": "int" }, - { "prim": "string" } - ], - "annots": [ "%node" ] } ], - "annots": [ ":point" ] }, [] ] }, { "prim": "DROP" } ] - |] - ] - where - lambdaWrap ty = "LAMBDA (" <> ty <> ") (" <> ty <> ") {}; DROP" - -deserializeNegTest :: Spec -deserializeNegTest = do - - describe "Wrong length specified" $ do - unpackNegSpec "Too few list length" - "0x05020000000300010002" -- { 1; 2 } - unpackNegSpec "Too big list length" - "0x05020000000500010002" -- { 1; 2 } - unpackNegSpec "Wrong bytes length" - "0x050b000000021234" -- 0x1234 - - describe "Invalid annotations specified" $ do - deserializeNegSpec - "Space char `20` in the middle of an annotation" - "0x050200000009041600000003252061" - [aesonQQ| [ { "prim": "CAR", "annots": [ "%a b" ] } ] |] - deserializeNegSpec - "Char from invalid range `00-1F` as part of an annotation" - "0x050200000009041600000003251A61" - [aesonQQ| [ { "prim": "CAR", "annots": [ "%\u001aa" ] } ] |] - deserializeNegSpec - "Char from invalid range `A0-FF` as part of an annotation" - "0x05020000000904160000000325A361" - [aesonQQ| [ { "prim": "CAR", "annots": [ "%!aa" ] } ] |] - -readableDeserializeTest :: Spec -readableDeserializeTest = do - describe "Deserialize primitives from Readable representation" $ do - -- tezos-client convert data '"tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A"' from michelson to binary - -- tezos-client convert data '"tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A"' from michelson to json - deserializeReadableSpec @'TAddress "Deserialize readable address" - "0x050100000024747a31616b63506d47314b797a326a587053345276564a38755772377473695439693641" - [aesonQQ| { "string": "tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A" } |] - -- ./tezos-client convert data '"edpktezaD1wnUa5pT2pvj1JGHNey18WGhPc9fk9bbppD33KNQ2vH8R"' - -- from michelson to binary - deserializeReadableSpec @'TKey "Deserialize readable public key" - "0x0501000000366564706b74657a614431776e55613570543270766a314a4\ - \7484e65793138574768506339666b39626270704433334b4e513276483852" - [aesonQQ| { "string": "edpktezaD1wnUa5pT2pvj1JGHNey18WGhPc9fk9bbppD33KNQ2vH8R" } |] - -- tezos-client convert data '"edsigtqgdc2JLMDcERHo61Y76mrxqCeqDE5YhHiBo\ - -- \VtwjhFKahAkCT7RCZKQLhLJ3yJbrVyJCkVGEoiHbyKytHW846dDC4P121K"' from michelson to binary - deserializeReadableSpec @'TSignature "Deserialize readable signature" - "0x05010000006365647369677471676463324a4c4d44634552486f36315937\ - \366d72787143657144453559684869426f5674776a68464b6168416b435437\ - \52435a4b514c684c4a33794a627256794a436b5647456f694862794b797448\ - \5738343664444334503132314b" - [aesonQQ| { "string": "edsigtqgdc2JLMDcERHo61Y76mrxqCeqDE5YhHiBoVtwjhFKahAkCT7RCZKQLhLJ3yJbrVyJCkVGEoiHbyKytHW846dDC4P121K" } |] - - -- tezos-client convert data '"NetXUdfLh6Gm88t"' from michelson to binary - deserializeReadableSpec @'TChainId "Deserialize readable chain_id" - "0x05010000000f4e6574585564664c6836476d383874" - [aesonQQ| { "string": "NetXUdfLh6Gm88t" } |] - - deserializeReadableSpec @'TTimestamp "Deserialize readable timestamp" - "0x050100000014323032302d30382d30365431303a35303a35395a" - [aesonQQ| { "string": "2020-08-06T10:50:59Z" } |] - - where - deserializeReadableSpec - :: forall t. UnpackedValScope t - => String -> Text -> J.Value -> Spec - deserializeReadableSpec name encodedHex json = - describe name $ do - it "From binary" $ - let encoded = unsafe . fromHex $ stripOptional0x encodedHex - in runUnpack @t encoded `shouldSatisfy` isRight - it "From json" $ - case J.eitherDecode' @Expression (J.encode json) of - Left err -> expectationFailure $ pretty err - Right expr -> do - fromExpression @(Value t) expr `shouldSatisfy` isRight - -lengthsAreNotIgnoredTest :: Spec -lengthsAreNotIgnoredTest = - describe "Lengths are not ignored in ChainId" $ do - let chainId = UnsafeChainId "\0\0\0\0" - properEncoded = unsafe $ fromHex "050a0000000400000000" - badEncodedGt = unsafe $ fromHex "050a0000000500000000" - badEncodedLt = unsafe $ fromHex "050a0000000300000000" - - it "Can be properly encoded" $ - unpackValue' @'TChainId properEncoded == Right (VChainId chainId) - it "Caught when greater than necessary" $ - isLeft $ unpackValue' @'TChainId badEncodedGt - it "Caught when less than necessary" $ - isLeft $ unpackValue' @'TChainId badEncodedLt - -deserializeIntAsNatTest :: Spec -deserializeIntAsNatTest = do - describe "non-negative 'int' can be parsed to 'nat'" $ do - it "From binary" $ - unpackValue' @'TNat (packValue' (VInt 1)) == Right (VNat 1) - it "From json" $ - fromExpression @(Value 'TNat) (toExpression @(Value 'TInt) (VInt 1)) == Right (VNat 1) - - describe "Can't be decoded because of negativity" $ do - it "From binary" $ - isLeft $ unpackValue' @'TNat (packValue' (VInt -1)) - it "From json" $ - isLeft $ fromExpression @(Value 'TNat) (toExpression @(Value 'TInt) (VInt -1)) - -deserializeComparablePairTest :: Spec -deserializeComparablePairTest = do - parseSerializeSpec "Deserialize a pair of comparable types" - [ "LEFT (set (pair nat nat)) ; DROP ; UNIT" - ~: "05020000000e053305660765036203620320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "set", - "args": - [ { "prim": "pair", - "args": [ { "prim": "nat" }, { "prim": "nat" } ] } ] } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - , "LEFT (set (pair unit unit)) ; DROP ; UNIT" - ~: "0x05020000000e053305660765036c036c0320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "set", - "args": - [ { "prim": "pair", - "args": [ { "prim": "unit" }, { "prim": "unit" } ] } ] } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - -deserializeComparableOrTest :: Spec -deserializeComparableOrTest = do - parseSerializeSpec "Deserialize comparable 'or'" - [ "LEFT (set (or nat nat)) ; DROP ; UNIT" - ~: "0x05020000000e053305660764036203620320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "set", - "args": - [ { "prim": "or", - "args": [ { "prim": "nat" }, { "prim": "nat" } ] } ] } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - -deserializeComparableOptionTest :: Spec -deserializeComparableOptionTest = do - parseSerializeSpec "Deserialize comparable 'option'" - [ "LEFT (option unit) ; DROP ; UNIT" - ~: "0x05020000000a05330563036c0320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "option", - "args": [ { "prim": "unit" } ] } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - -deserializeComparablesTest :: Spec -deserializeComparablesTest = do - parseSerializeSpec "Deserialize comparable simple types" - [ "LEFT unit ; DROP ; UNIT" - ~: "0x0502000000080533036c0320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "unit" } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - , "LEFT chain_id ; DROP ; UNIT" - ~: "0x050200000008053303740320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "chain_id" } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - , "LEFT signature ; DROP ; UNIT" - ~: "0x050200000008053303670320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "signature" } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - , "LEFT key ; DROP ; UNIT" - ~: "0x0502000000080533035c0320034f" - ~: [aesonQQ| - [ { "prim": "LEFT", - "args": - [ { "prim": "key" } ] }, - { "prim": "DROP" }, { "prim": "UNIT" } ] - |] - ] - -deserializeSeqOfEmptySeqsTest :: Spec -deserializeSeqOfEmptySeqsTest = do - parseSerializeSpec "unambiguously converting sequence of empty sequences" - [ - "PUSH (list (list int)) { {} }; DROP" - ~: "0502000000140743055f055f035b020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "list", - "args": [ { "prim": "list", - "args":[ { "prim": "int" } ] } ] }, - [ [] ] ] }, { "prim": "DROP" } ] - |] - , "PUSH (lambda int int) { {} }; DROP" - ~: "0502000000140743075e035b035b020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "lambda", - "args": [ { "prim": "int" }, { "prim": "int" } ] }, [ [] ] ] }, - { "prim": "DROP" } ] - |] - , "PUSH (list (list (list int))) { { {} } }; DROP" - ~: "05020000001b0743055f055f055f035b020000000a020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "list", "args": - [ { "prim": "list", - "args": - [ { "prim": "list", "args": [ { "prim": "int" } ] } ] - } - ] - }, - [ [ [] ] ] ] - }, - { "prim": "DROP" } - ] - |] - , "PUSH (lambda int int) { { {} } }; DROP" - ~: "0502000000190743075e035b035b020000000a020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "lambda", - "args": [ { "prim": "int" }, { "prim": "int" } ] }, [ [ [] ] ] ] }, - { "prim": "DROP" } ] - |] - , "PUSH (lambda int int) { {}; { {} } }; DROP" - ~: "05020000001e0743075e035b035b020000000f0200000000020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "lambda", - "args": [ { "prim": "int" }, { "prim": "int" } ] }, - [ [], [ [] ] ] - ] - }, - { "prim": "DROP" } - ] - |] - , "PUSH (list (set int)) { {} }; DROP" - ~: "0502000000140743055f0566035b020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "list", - "args": [ { "prim": "set", "args": [ { "prim": "int" } ] } ] }, - [ [] ] - ] - }, - { "prim": "DROP" } - ] - |] - , "PUSH (list (map int int)) { {} }; DROP" - ~: "0502000000160743055f0760035b035b020000000502000000000320" - ~: [aesonQQ| - [ { "prim": "PUSH", - "args": - [ { "prim": "list", - "args": - [ { "prim": "map", - "args": [ { "prim": "int" }, { "prim": "int" } ] } ] }, - [ [] ] - ] - }, - { "prim": "DROP" } - ] - |] - ] diff --git a/morley-test/Test/Serialization/Util.hs b/morley-test/Test/Serialization/Util.hs deleted file mode 100644 --- a/morley-test/Test/Serialization/Util.hs +++ /dev/null @@ -1,118 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# LANGUAGE OverloadedLists #-} - - -module Test.Serialization.Util - ( Example(..) - , TestMethod(..) - , deserializeNegSpecImpl - , examples - , fromBinaryTestMethodImpl - , fromJsonTestMethodImpl - , serializeSpecManualImpl - , toBinaryTestMethodImpl - , toJsonTestMethodImpl - , (~:) - ) where - -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) -import Test.Hspec.Expectations (expectationFailure) -import Text.Hex (encodeHex) - -import Morley.Micheline.Class (FromExpression(..), ToExpression(..)) -import Morley.Micheline.Expression (Expression) -import Morley.Michelson.Interpret.Unpack -import Test.Cleveland.Util - --- | Helper for defining tests cases for 'serializeSpec'. -(~:) :: a -> b -> (a, b) -(~:) = (,) -infixr 0 ~: - --- | Dummy wrapper for the data needed to test an example scenario + its name. -data Example a = Example - { _eTestName :: String - , _eTestData :: a - } - --- | Creates a list of example scenarios and labels them using their index. --- examples :: [a] -> [Example a] -examples :: [a] -> [Example a] -examples xs = - xs `zip` [1..] <&> - \(testData, index) -> Example ("Example #" <> show @String @Int index) testData - --- | Dummy wrapper for what do we test - serialize/deserialize from/to binary/json. -data TestMethod t = TestMethod - { _tmName :: String - , _tmApply :: t -> Text -> J.Value -> Expectation - } - -toBinaryTestMethodImpl :: HasCallStack => (t -> ByteString) -> [TestMethod t] -toBinaryTestMethodImpl doPack = one $ - TestMethod "To binary" $ - \val encodedHex _ -> - encodeHex (doPack val) `shouldBe` stripOptional0x encodedHex - -fromBinaryTestMethodImpl :: (HasCallStack, Show t, Eq t) => (ByteString -> Either UnpackError t) -> [TestMethod t] -fromBinaryTestMethodImpl doUnpack = one $ - TestMethod "From binary" $ - \val encodedHex _ -> - doUnpack (unsafe . fromHex $ encodedHex) `shouldBe` Right val - -toJsonTestMethodImpl :: (ToExpression t) => HasCallStack => [TestMethod t] -toJsonTestMethodImpl = one $ - TestMethod "To json" $ - \val _ expectedJson -> do - let actualJson = J.toJSON (toExpression val) - ShowWith prettify actualJson `shouldBe` ShowWith prettify expectedJson - where - prettify :: J.Value -> String - prettify = - decodeUtf8 . encodePretty' - -- we use `confCompare` to reverse the order of the json keys, so that `prim` appears before `args`. - (defConfig { confCompare = \x y -> compare y x, confIndent = Spaces 2 }) - -fromJsonTestMethodImpl :: forall t. (FromExpression t, Show t, Eq t) => HasCallStack => [TestMethod t] -fromJsonTestMethodImpl = one $ - TestMethod "From json" $ - \expectedVal _ json -> do - case J.eitherDecode' @Expression (J.encode json) of - Left err -> expectationFailure $ pretty err - Right expr -> do - case fromExpression @t expr of - Left err -> expectationFailure $ pretty err - Right val -> - val `shouldBe` expectedVal - -serializeSpecManualImpl - :: forall y x. (HasCallStack) - => (y -> x) -> String -> [TestMethod x] -> [Example (y, (Text, J.Value))] -> Spec -serializeSpecManualImpl toVal' name testMethods suites = - forM_ @[_] testMethods $ \(TestMethod mname method) -> - describe mname $ - describe name $ forM_ suites $ \(Example exampleName (x, (hex, json))) -> - it exampleName $ method (toVal' x) hex json - -deserializeNegSpecImpl - :: forall t. (FromExpression t, Show t) - => (ByteString -> Either UnpackError t) - -> String - -> Text - -> J.Value - -> Spec -deserializeNegSpecImpl doUnpack name encodedHex json = - describe name $ do - it "From binary" $ - let encoded = unsafe . fromHex $ stripOptional0x encodedHex - in doUnpack encoded `shouldSatisfy` isLeft - it "From json" $ - case J.eitherDecode' @Expression (J.encode json) of - Left _ -> pass - Right expr -> do - fromExpression @t expr `shouldSatisfy` isLeft diff --git a/morley-test/Test/Tezos/Address.hs b/morley-test/Test/Tezos/Address.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Address.hs +++ /dev/null @@ -1,94 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Tezos.Address'. - -module Test.Tezos.Address - ( test_Roundtrip - , test_parseAddress - , test_decodeAddress - , unit_ta - ) where - -import Test.HUnit (Assertion, (@?=)) -import Test.Hspec (shouldSatisfy) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Tezos.Address (genAddress) -import Morley.Tezos.Address (formatAddress, parseAddress, ta) -import Test.Cleveland.Util (parseAddressFromHex) - -import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) - -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ testGroup "parse . format ≡ pure" - [ roundtripTreeSTB genAddress formatAddress parseAddress ] - , testGroup "JSON encoding/deconding" - [ aesonRoundtrip genAddress ] - ] - -test_parseAddress :: [TestTree] -test_parseAddress = - [ 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 (parseAddressFromHex b) `shouldSatisfy` isRight) - , testCase "Parsed addresses are equivalent in canonical and raw byte form" $ - 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) - ] - -test_decodeAddress :: [TestTree] -test_decodeAddress = mconcat - [ [ testCase ("Successfully encodes " <> toString b) - (formatAddress (unsafe $ parseAddressFromHex b) @?= a) | (a, b) <- sampleAddresses ] - , [ testCase ("Fails to parse invalid address " <> toString a) - (parseAddressFromHex a `shouldSatisfy` isLeft) | a <- invalidRawAddresses ] - ] - -unit_ta :: Assertion -unit_ta = do - [ta|tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU|] - @?= unsafe (parseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU") - [ta|tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd|] - @?= unsafe (parseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd") - [ta|KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45|] - @?= unsafe (parseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45") - [ta|KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh|] - @?= unsafe (parseAddress "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh") - -sampleAddresses :: [(Text, Text)] -sampleAddresses = - [ ("tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU", "0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd6") - , ("tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd", "000079943a60100e0394ac1c8f6ccfaeee71ec9c2d94") - , ("tz2EfqCbLmpfv7mNiLcMmhxAwdgHtPTcwR4W", "000145b5e7d31bf6612e61ebfa7a6d929ce7800a55a4") - , ("tz2Darj3LyQzekU98ZK8diHvuyn1YYjcHpc6", "000139ccf913874519b2d20917bf5f2de537420d2726") - , ("tz3UoffC7FG7zfpmvmjUmUeAaHvzdcUvAj6r", "00025cfa532f50de3e12befc0ad21603835dd7698d35") - , ("tz3NExpXn9aPNZPorRE4SdjJ2RGrfbJgMAaV", "000214fa2b36471a318d2f244997c48c5f23b8001eed") - , ("KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45", "01521139f84791537d54575df0c74a8084cc68861c00") - , ("KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh", "01afab866e7f1e74f9bba388d66b246276ce50bf4700") - ] - -invalidRawAddresses :: [Text] -invalidRawAddresses = - [ "" - , "qehrwu" - , "0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd" - , "0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd6a" - , "0000dac9f52543da1aed0bc1d6b46bf7c10db7014cds" - , "1000dac9f52543da1aed0bc1d6b46bf7c10db7014cd6" - ] - -invalidAddresses :: [Text] -invalidAddresses = - [ "" - , "1" - -- These are slightly modified versions of some valid addresses above. - , "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUZU" - , "tz2darj3LyQzekU98ZK8diHvuyn1YYjcHpc6" - , "tz3UoffC8FG7zfpmvmjUmUeAaHvzdcUvAj6r" - , "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE46" - ] diff --git a/morley-test/Test/Tezos/Core.hs b/morley-test/Test/Tezos/Core.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Core.hs +++ /dev/null @@ -1,80 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Tezos.Core - ( test_ParseTimestamp - , test_TimestampQuote - , test_ChainId_roundtrip - , test_Parse_ChainId - ) where - -import Test.HUnit ((@?=)) -import Test.Hspec (shouldBe, shouldSatisfy) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Tezos.Core (genChainId) -import Morley.Tezos.Core - -import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) - ----------------------------------------------------------------------------- --- Timestamp ----------------------------------------------------------------------------- - -test_ParseTimestamp :: [TestTree] -test_ParseTimestamp = - [ testCase "Correctly parse valid inputs" $ do - parseTimestamp "2018-08-08T00:00:00Z" `shouldBe` Just (Timestamp 1533686400) - parseTimestamp "2018-08-08 00:00:00Z" `shouldBe` Just (Timestamp 1533686400) - - , testCase "Does not parse leading and trailing spaces" $ do - parseTimestamp " 2018-08-08T00:00:00Z" `shouldSatisfy` isNothing - parseTimestamp "2018-08-08T00:00:00Z " `shouldSatisfy` isNothing - parseTimestamp " 2018-08-08T00:00:00Z " `shouldSatisfy` isNothing - - , testCase "Does not parse with multiple separating spaces" $ do - parseTimestamp "2018-08-08 00:00:00Z" `shouldSatisfy` isNothing - parseTimestamp "2018-08-08 00:00:00Z" `shouldSatisfy` isNothing - ] - -test_TimestampQuote :: [TestTree] -test_TimestampQuote = - [ testCase "Quoter works in simple case" $ - [timestampQuote|2019-07-26T12:09:12Z|] - @?= timestampFromSeconds 1564142952 - - , testCase "Quoter works with surrounding spaces" $ - [timestampQuote| 2019-07-26T12:09:12Z |] - @?= timestampFromSeconds 1564142952 - ] - ----------------------------------------------------------------------------- --- ChainId ----------------------------------------------------------------------------- - -test_ChainId_roundtrip :: [TestTree] -test_ChainId_roundtrip = - [ testGroup "parse . format ≡ pure" - [ roundtripTreeSTB genChainId formatChainId parseChainId ] - , testGroup "JSON encoding/deconding" - [ aesonRoundtrip genChainId ] - ] - -test_Parse_ChainId :: [TestTree] -test_Parse_ChainId = - [ testCase "Successfully parses valid sample data" $ - forM_ sampleChainIds (\a -> bimap STB STB (parseChainId a) `shouldSatisfy` isRight) - , testCase "Fails to parse invalid data" $ do - forM_ invalidChainIds (\a -> bimap STB STB (parseChainId a) `shouldSatisfy` isLeft) - ] - where - sampleChainIds = - [ "NetXUdfLh6Gm88t" - ] - invalidChainIds = - [ "" - , "1" - , "NetXUdfLh6Gm88r" -- last char changed - , "5uYAAtMU9Bi2Qe" -- valid base58, wrong size - ] diff --git a/morley-test/Test/Tezos/Crypto.hs b/morley-test/Test/Tezos/Crypto.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Crypto.hs +++ /dev/null @@ -1,394 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Tezos.Crypto'. - -module Test.Tezos.Crypto - ( test_Roundtrip - , test_Signing - , test_parseRawSignature - , test_parseRawPublicKey - , test_parseRawKeyHash - , unit_Key_Hashing - , unit_Failing_Key_Hashing - ) where - -import Fmt (pretty) -import Test.HUnit (Assertion, assertBool, (@?=)) -import Test.Hspec (Expectation, shouldSatisfy) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSecretKey, genSignature) -import Morley.Tezos.Crypto -import Test.Cleveland.Util (fromHex) -import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) - -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ testGroup "parse . format ≡ pure" - [ roundtripTreeSTB genPublicKey formatPublicKey parsePublicKey - , roundtripTreeSTB genSignature formatSignature parseSignature - , roundtripTreeSTB genKeyHash formatKeyHash parseKeyHash - , roundtripTreeSTB genSecretKey formatSecretKey parseSecretKey - ] - , testGroup "JSON encoding/deconding" - [ aesonRoundtrip genPublicKey - , aesonRoundtrip genSignature - , aesonRoundtrip genKeyHash - ] - ] - ----------------------------------------------------------------------------- --- Signing ----------------------------------------------------------------------------- - -test_Signing :: [TestTree] -test_Signing = - [ testGroup "Formatting" - [ testGroup "parsePublicKey" - [ testCase "Successfully parses valid sample data" $ - mapM_ (parsePublicKeySample . sdPublicKey) sampleSignatures - , testCase "Fails to parse invalid data" $ do - parsePublicKeyInvalid "" - parsePublicKeyInvalid "aaa" - - parsePublicKeyInvalid - "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3v" - parsePublicKeyInvalid - "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" - - parsePublicKeyInvalid - "sppk7Ze7NMs6EHF2uB8qq8GrEgJvE9PWYkUijN3LcesafzQuGyniHBd" - parsePublicKeyInvalid - "spsig1Ng2bs4PXCbjaFGuojk9K5Pt3CkfbUZyHLLrBxHSmTqrUUxQggi4yJBit3Ljqnqr61UpdTewTLiu4schSCfZvaRwu412oZ" - - parsePublicKeyInvalid - "p2pk68C6tJr7pNLvgBH63K3hBVoztCPCA36zcWhXFUGywQJTjYbfpxk" - parsePublicKeyInvalid - "p2sigRmXDp38VNVaEQH28LYukfLPn8QB5hPEberhvQrrUpRscDZJrrApbRh2u46PTVTwKXjxTLKNN9dyLhPQU6U6jWPGxe4d9v" - ] - , testGroup "parseSecretKey" - [ testCase "Successfully parses valid sample data" $ - mapM_ parseSecretKeySample - [ "spsk1wt9QxrpLg8UCR2S9YqXSP3YaTBCpSx3dnf62pQuw2wj7Sb8uL" - , "p2sk32DYyag6h9GSMmysxsvM9LzWwC5rV1QqZAwivUuJ3zrjSKK1Pj" - , "unencrypted:spsk1wt9QxrpLg8UCR2S9YqXSP3YaTBCpSx3dnf62pQuw2wj7Sb8uL" - , "unencrypted:p2sk32DYyag6h9GSMmysxsvM9LzWwC5rV1QqZAwivUuJ3zrjSKK1Pj" - ] - ] - , testGroup "parseSignature" - [ testCase "Successfully parses valid sample data" $ - mapM_ (parseSignatureSample . sdSignature) sampleSignatures - , testCase "Fails to parse invalid data" $ do - parseSignatureInvalid "" - parseSignatureInvalid "bbb" - - parseSignatureInvalid - "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" - parseSignatureInvalid - "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vB" - - parseSignatureInvalid - "sppk7cdA7Afj8MvuBFrP6KsTLfbM5DtH9GwYaRZwCf5tBVCz6UKGQFR" - parseSignatureInvalid - "spsig1Ng2bs4PXCbjaFGuojk9K5Pt3ckfbUZyHLLrBxHSmTqrUUxQggi4yJBit3Ljqnqr61UpdTewTLiu4schSCfZvaRwu412oZ" - - parseSignatureInvalid - "p2pk68C6tJr7pNLvgBH63K3hBVoztCPCA36zcWhXFUGywQJTjYBfpxk" - parseSignatureInvalid - "p2sigRmXDp38VNVaEQH28LYukfLPn8QB5hPEberhvQrrUpRscDZJrrApbrh2u46PTVTwKXjxTLKNN9dyLhPQU6U6jWPGxe4d9v" - ] - ] - , testCase "checkSignature" $ mapM_ checkSignatureSample sampleSignatures - , testCase "checkRawSignature" $ mapM_ checkRawSignatureSample sampleRawSignatures - ] - -data SignatureData = SignatureData - { sdPublicKey :: Text - , sdBytes :: ByteString - , sdSignature :: Text - , sdValid :: Bool - } - --- These signatures have been produced by `tezos-client`. -sampleSignatures :: [SignatureData] -sampleSignatures = - [ SignatureData - { sdPublicKey = "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" - , sdBytes = "\0" - , sdSignature = "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" - , sdValid = True - } - , SignatureData - { sdPublicKey = "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - , sdBytes = "\0\0" - , sdSignature = "edsigtj8LhbJ2B3qhZvqzA49raG65dydFcWZW9b9L7ntF3bb29zxaBFFL8SM1jeBUY66hG122znyVA4wpzLdwxcNZwSK3Szu7iD" - , sdValid = True - } - , SignatureData - { sdPublicKey = "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - , sdBytes = "kot" - , sdSignature = "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" - , sdValid = False - } - ] - <> - [ SignatureData - { sdPublicKey = "sppk7cdA7Afj8MvuBFrP6KsTLfbM5DtH9GwYaRZwCf5tBVCz6UKGQFR" - , sdBytes = "\0" - , sdSignature = "spsig1Ng2bs4PXCbjaFGuojk9K5Pt3CkfbUZyHLLrBxHSmTqrUUxQggi4yJBit3Ljqnqr61UpdTewTLiu4schSCfZvaRwu412oZ" - , sdValid = True - } - , SignatureData - { sdPublicKey = "sppk7Ze7NMs6EHF2uB8qq8GrEgJvE9PWYkUijN3LcesafzQuGyniHBD" - , sdBytes = "\0\0" - , sdSignature = "spsig1aP7D9oheiraNuM1NgziMPSPKS1F9kSWyFqkE8WigaeU5Uzb3LwY34F7Y7RsF6sY5ZfUda1NWdrC5V4KEfm9jeU1eniHmy" - , sdValid = True - } - , SignatureData - { sdPublicKey = "sppk7Ze7NMs6EHF2uB8qq8GrEgJvE9PWYkUijN3LcesafzQuGyniHBD" - , sdBytes = "kot" - , sdSignature = "spsig1PJ9LG9ovbpVJ3CucFWL7iBaQZjqEWMvppgLjYiiSwzcxpuUqHr2BUVZDUwkmZKzMNDWJdgtyhYiicz197TbhS4LPpnxDY" - , sdValid = False - } - ] - <> - [ SignatureData - { sdPublicKey = "p2pk66qfVMXhFJWhtFDCT6F3JUM3M1iQpfWe4nPZKWcsqsKQtXXHFkQ" - , sdBytes = "\0" - , sdSignature = "p2sigv6HrN6xB5gQDnmKLC2P3ynwiPn4zfUj7CcZD1cepfFzX7xBDWFQu9uoKWbEzVgxCQxrE1J5X6FGYwF2dpoYcjpdPCBhuD" - , sdValid = True - } - , SignatureData - { sdPublicKey = "p2pk64bybDUtSjSQnsexpzhedhBo4vkoRX4tWfQQbBxKbA58wJqKkT2" - , sdBytes = "\10" - , sdSignature = "p2siggzjojhabur7zZvmNnhkhnU3nYA1ZUR9JSas57RVhNdAmQk6y3hns3F2zPBGsC964PFAE2HC3fbPkcqpVFbjoQQq9dFiZg" - , sdValid = True - } - , SignatureData - { sdPublicKey = "p2pk64bybDUtSjSQnsexpzhedhBo4vkoRX4tWfQQbBxKbA58wJqKkT2" - , sdBytes = "kot" - , sdSignature = "p2siggzjojhabur7zZvmNnhkhnU3nYA1ZUR9JSas57RVhNdAmQk6y3hns3F2zPBGsC964PFAE2HC3fbPkcqpVFbjoQQq9dFiZg" - , sdValid = False - } - ] - -sampleRawSignatures :: [SignatureData] -sampleRawSignatures = - [ SignatureData - { sdPublicKey = "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082" - , sdBytes = "\0" - , sdSignature = "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201" - , sdValid = True - } - , SignatureData - { sdPublicKey = "0103b524d0184276467c848ac13557fb0ff8bec5907960f72683f22af430503edfc1" - , sdBytes = "\0" - , sdSignature = "80e4e72ffecf72953789625b1125e9f45f432c14e53a01ec68a1e1b77d60cfe96a97443733ba0f7f42db3a56d7a433df2b4fc0035c05ab92d062f33c5bab0244" - , sdValid = True - } - , SignatureData - { sdPublicKey = "0202041e5cb7fb3d7bc6fb7b9e94790919a9e76ccc372e6cc9cae925027c08ff95f3" - , sdBytes = "\10" - , sdSignature = "12d25210bb02998516bf6a776e1cd55a06c5fbe3c21afbeef29b99d96305e43263c75a4449906e0f2d79ecc973fff9ce7f8c43fee40b04d07c191f00ee176175" - , sdValid = True - } - ] - -parsePublicKeySample :: Text -> Expectation -parsePublicKeySample publicKeyText = - parsePublicKey publicKeyText `shouldSatisfy` isRight - -parseSecretKeySample :: Text -> Expectation -parseSecretKeySample secretKeyText = - parseSecretKey secretKeyText `shouldSatisfy` isRight - -parsePublicKeyInvalid :: Text -> Expectation -parsePublicKeyInvalid invalidPublicKeyText = - parsePublicKey invalidPublicKeyText `shouldSatisfy` isLeft - -parseSignatureSample :: Text -> Expectation -parseSignatureSample signatureText = - parseSignature signatureText `shouldSatisfy` isRight - -parseSignatureInvalid :: Text -> Expectation -parseSignatureInvalid invalidSignatureText = - parseSignature invalidSignatureText `shouldSatisfy` isLeft - -checkSignatureSample :: SignatureData -> Assertion -checkSignatureSample sd = - checkSignature publicKey signature (sdBytes sd) @?= sdValid sd - where - publicKey = unsafe . parsePublicKey $ sdPublicKey sd - signature = unsafe . parseSignature $ sdSignature sd - -checkRawSignatureSample :: SignatureData -> Assertion -checkRawSignatureSample sd = - checkSignature publicKey signature (sdBytes sd) @?= sdValid sd - where - publicKey = unsafe . parsePublicKeyRaw . unsafe . fromHex $ sdPublicKey sd - signature = unsafe . parseSignatureRaw . unsafe . fromHex $ sdSignature sd - ----------------------------------------------------------------------------- --- Key hashing ----------------------------------------------------------------------------- - -unit_Key_Hashing :: Assertion -unit_Key_Hashing = mapM_ hashKeySample sampleKeyHashes - -unit_Failing_Key_Hashing :: Assertion -unit_Failing_Key_Hashing = assertBool "Parsed key hash of invalid length" $ - isLeft $ parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSxZ" - -sampleKeyHashes :: [(Text, Text)] -sampleKeyHashes = - [ ( "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - , "tz1NaZzLvdDBLfV2LWC6F4SJfNV2jHdZJXkJ" - ) - , ( "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" - , "tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw" - ) - , ( "sppk7cdA7Afj8MvuBFrP6KsTLfbM5DtH9GwYaRZwCf5tBVCz6UKGQFR" - , "tz2EfqCbLmpfv7mNiLcMmhxAwdgHtPTcwR4W" - ) - , ( "sppk7Ze7NMs6EHF2uB8qq8GrEgJvE9PWYkUijN3LcesafzQuGyniHBD" - , "tz2Darj3LyQzekU98ZK8diHvuyn1YYjcHpc6" - ) - , ( "p2pk67K1dwkDFPB63RZU5H3SoMCvmJdKZDZszc7U4FiGKN2YypKdDCB" - , "tz3S7wbUwQV581kroR81fYbgDBskFicZ6czW" - ) - , ( "p2pk68C6tJr7pNLvgBH63K3hBVoztCPCA36zcWhXFUGywQJTjYBfpxk" - , "tz3QEbmdCdsMcnUo2rNjXdbKwg5tyack3goN" - ) - ] - -hashKeySample :: (Text, Text) -> Assertion -hashKeySample (pkText, keyHashText) = hashKey pk @?= keyHash - where - pk = unsafe $ parsePublicKey pkText - keyHash = unsafe $ parseKeyHash keyHashText - ----------------------------------------------------------------------------- --- Parsing raw data ----------------------------------------------------------------------------- - -test_parseRawSignature :: [TestTree] -test_parseRawSignature = - [ 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 . unsafe . fromHex $ b) `shouldSatisfy` isRight) - , testCase "Parsed signatures are equivalent in canonical and raw byte form" $ - forM_ samplePairSignatures (\(a, b) -> - (STB . unsafe . parseSignatureRaw . unsafe . fromHex $ b) - @?= (STB . unsafe . parseSignature $ a)) - , testGroup "Fails to parse invalid signatures:" - [ testCase (toString a) - (parseInvalidSignature a `shouldSatisfy` isLeft) | a <- invalidRawSignatures - ] - ] - - where - parseInvalidSignature :: Text -> Either Text Signature - parseInvalidSignature a = do - bs <- fromHex a - first pretty $ parseSignatureRaw bs - - samplePairSignatures :: [(Text, Text)] - samplePairSignatures = - [ ( "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb" - , "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201") - , ( "edsigtj8LhbJ2B3qhZvqzA49raG65dydFcWZW9b9L7ntF3bb29zxaBFFL8SM1jeBUY66hG122znyVA4wpzLdwxcNZwSK3Szu7iD" - , "568722d9942f516ab369e7803b5646775459ef93080842400354cb638800861bb051509fcef5ad6940ba38af3697d09f1be5be829b8f6f50610ef28606755d0e") - , ( "spsig1PJ9LG9ovbpVJ3CucFWL7iBaQZjqEWMvppgLjYiiSwzcxpuUqHr2BUVZDUwkmZKzMNDWJdgtyhYiicz197TbhS4LPpnxDY" - , "85a75c026ae48f5e8d4891e30da2eef1174987f94401881e216c9e217d14247908ea0303579c1df08d70364e7309b410adb4f71787464df001bf7699a0749c8f") - , ( "p2sigRmXDp38VNVaEQH28LYukfLPn8QB5hPEberhvQrrUpRscDZJrrApbRh2u46PTVTwKXjxTLKNN9dyLhPQU6U6jWPGxe4d9v" - , "22222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222") - ] - - invalidRawSignatures :: [Text] - invalidRawSignatures = - [ "" - , "ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201" - , "a91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd891cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201" - , "222222222222222222222222222222222222222222222222222222222222222222222222222" - ] - -test_parseRawPublicKey :: [TestTree] -test_parseRawPublicKey = - [ 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 . unsafe . fromHex $ b) `shouldSatisfy` isRight) - , testCase "Parsed public keys are equivalent in canonical and raw byte form" $ - 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` isLeft) | a <- invalidRawPublicKeys - ] - ] - - where - parseInvalidKey :: Text -> Either Text PublicKey - parseInvalidKey a = do - bs <- fromHex a - first pretty $ parsePublicKeyRaw bs - - sampleRawPublicKeys :: [(Text, Text)] - sampleRawPublicKeys = - [ ( "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - , "009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d") - , ( "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH" - , "009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d") - , ( "sppk7cdA7Afj8MvuBFrP6KsTLfbM5DtH9GwYaRZwCf5tBVCz6UKGQFR" - , "0103b524d0184276467c848ac13557fb0ff8bec5907960f72683f22af430503edfc1") - , ( "p2pk67K1dwkDFPB63RZU5H3SoMCvmJdKZDZszc7U4FiGKN2YypKdDCB" - , "020368afbb09255d849813712108a4144237dc1fdd5bb74e68335f4c68c12c1e5723") - ] - - invalidRawPublicKeys :: [Text] - invalidRawPublicKeys = - [ "" - , "009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8" - , "0009a85e0f3f47852869ae667adc3b03a20fa9f324d046174dff6834e7d1fab0e8d" - ] - -test_parseRawKeyHash :: [TestTree] -test_parseRawKeyHash = - [ 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 . unsafe . fromHex $ b) `shouldSatisfy` isRight) - , testCase "Parsed key hashes are equivalent in canonical and raw byte form" $ - 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` isLeft) | a <- invalidRawKeyHashes - ] - ] - where - parseInvalidKey :: Text -> Either Text KeyHash - parseInvalidKey a = do - bs <- fromHex a - first pretty $ parseKeyHashRaw bs - - sampleRawKeyHashes :: [(Text, Text)] - sampleRawKeyHashes = - [ ("tz1NaZzLvdDBLfV2LWC6F4SJfNV2jHdZJXkJ" - ,"002040d6c2ede06fbd1cbc16d51c3085dc2e43e396") - , ("tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw" - ,"0092629ed0afa9cd42835ce09ee2623c1efa0b590d") - , ("tz2EfqCbLmpfv7mNiLcMmhxAwdgHtPTcwR4W" - ,"0145b5e7d31bf6612e61ebfa7a6d929ce7800a55a4") - , ("tz2Darj3LyQzekU98ZK8diHvuyn1YYjcHpc6" - ,"0139ccf913874519b2d20917bf5f2de537420d2726") - ] - - invalidRawKeyHashes :: [Text] - invalidRawKeyHashes = - [ "" - , "15002040d6c2ede06fbd1cbc16d51c3085dc2e43e396" - , "100000015002040d6c2ede06fbd1cbc16d51c3085dc2e43e396" - , "1100000015002040d6c2ede06fbd1cbc16d51c3085dc2e43e396" - ] diff --git a/morley-test/Test/Tezos/Crypto/BLS12381.hs b/morley-test/Test/Tezos/Crypto/BLS12381.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Crypto/BLS12381.hs +++ /dev/null @@ -1,223 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Tezos.Crypto.BLS12381'. --- --- Tezos has some Python tests that we make use of in our module: --- . -module Test.Tezos.Crypto.BLS12381 - ( test_SerializationRoundtrip - , test_SerializationTrivialCases - , test_SerializationEdgeCases - , test_PairingCheck - ) where - -import Prelude hiding (negate) - -import Data.ByteString qualified as BS -import Hedgehog (Gen, assert, forAll, property, withTests, (===)) -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) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Tezos.Crypto.BLS12381 -import Morley.Tezos.Crypto.BLS12381 -import Morley.Util.Named ((!)) -import Test.Cleveland.Util - -test_SerializationRoundtrip :: [TestTree] -test_SerializationRoundtrip = - [ roundtripTest genBls12381Fr - , roundtripTest genBls12381G1 - , roundtripTest genBls12381G2 - ] - where - roundtripTest gen = - roundtripTree gen toMichelsonBytes fromMichelsonBytes - -test_SerializationTrivialCases :: [TestTree] -test_SerializationTrivialCases = - [ testGroup "Zero" - [ testCase "Fr" $ - zero @Bls12381Fr @?= - -- this and other constants are defined below - unsafe (fromMichelsonBytes frZeroValue) - - , testCase "G1" $ - zero @Bls12381G1 @?= - unsafe (fromMichelsonBytes g1ZeroValue) - - , testCase "G2" $ - zero @Bls12381G2 @?= - unsafe (fromMichelsonBytes g2ZeroValue) - - ] - - , testGroup "One" - [ testCase "Fr" $ - (1 :: Bls12381Fr) @?= - unsafe (fromMichelsonBytes frOneValue) - - , testCase "G1" $ - g1One @?= - unsafe (fromMichelsonBytes g1OneValue) - - , testCase "G2" $ - g2One @?= - unsafe (fromMichelsonBytes g2OneValue) - - ] - - , testGroup "Negate one" - [ testCase "Fr" $ - negate (1 :: Bls12381Fr) @?= - unsafe (fromMichelsonBytes frMinusOneValue) - - , testCase "G1" $ - negate g1One @?= - unsafe (fromMichelsonBytes g1MinusOneValue) - - , testCase "G2" $ - negate g2One @?= - unsafe (fromMichelsonBytes g2MinusOneValue) - - ] - - ] - -test_SerializationEdgeCases :: [TestTree] -test_SerializationEdgeCases = - [ testGroup "Fr" - [ testCase "Smaller length" $ - fromMichelsonBytes @Bls12381Fr (unsafe $ fromHex "0100") - @?= Right 1 - - , testCase "Larger length" $ - fromMichelsonBytes @Bls12381Fr (unsafe . fromHex . mconcat $ replicate 33 "00") - @?= Left (TooLargeLength ! #limit 32 ! #given 33) - - , testCase "Too big bytes value" $ - fromMichelsonBytes @Bls12381Fr frMaxBoundPlusOne - @?= Left (ValueOutsideOfField $ toInteger @Bls12381Fr maxBound + 1) - - , testCase "Big decimal value" $ - -- We assume that 'fromIntegralOverflowing' is used to read numeric bls12_381_fr - -- values in Michelson - fromIntegralOverflowing @Integer @Bls12381Fr (toInteger @Bls12381Fr maxBound + 1) - @?= 0 - - , testCase "Negative decimal value" $ - fromIntegralOverflowing @Integer @Bls12381Fr (-1) - @?= (-1) - ] - - , testGroup "G1" - [ testCase "Smaller length" $ - fromMichelsonBytes @Bls12381G1 (stripLastByte g1SomeVal) - @?= Left (UnexpectedLength ! #expected 96 ! #given 95) - - , testCase "Larger length" $ - fromMichelsonBytes @Bls12381G1 (g1SomeVal <> "\0") - @?= Left (UnexpectedLength ! #expected 96 ! #given 97) - - , testCase "Bad value" $ - fromMichelsonBytes @Bls12381G1 (incrementBytes g1SomeVal) - @?= Left (PointNotOnCurve $ incrementBytes g1SomeVal) - - ] - - , testGroup "G2" - [ testCase "Smaller length" $ - fromMichelsonBytes @Bls12381G2 (stripLastByte g2SomeVal) - @?= Left (UnexpectedLength ! #expected 192 ! #given 191) - - , testCase "Larger length" $ - fromMichelsonBytes @Bls12381G2 (g2SomeVal <> "\0") - @?= Left (UnexpectedLength ! #expected 192 ! #given 193) - - , testCase "Bad value" $ - fromMichelsonBytes @Bls12381G2 (incrementBytes g2SomeVal) - @?= Left (PointNotOnCurve $ incrementBytes g2SomeVal) - - ] - - ] - -test_PairingCheck :: [TestTree] -test_PairingCheck = - [ testCase "Empty list" $ - -- Definition of @PAIRING_CHECK@ instruction explicitly says the expected - -- behaviour for an empty list - checkPairing [] @?= True - - , testProperty "Random stuff" $ withTests 5 $ property do - -- If randomly generated points ever paired (after a reasonably limited - -- number of attempts), then this curve would have problems - pairs <- forAll $ Gen.list (Range.linear 1 10) genPair - checkPairing pairs === False - - , testGroup "Non-trivial pairing matches" - [ testProperty "Pairing with negative" $ withTests 1 $ property do - -- This property is from here: https://github.com/ethereum/py_ecc/blob/3f644b4c07c8270b8fbe989eb799766aca66face/tests/test_bn128_and_bls12_381.py#L277 - (g1, g2) <- forAll genPair - assert $ checkPairing [(g1, g2), (g1, negate g2)] - assert $ checkPairing [(g1, g2), (negate g1, g2)] - ] - - ] - where - genPair :: Gen (Bls12381G1, Bls12381G2) - genPair = (,) <$> genBls12381G1 <*> genBls12381G2 - --- Helpers ----------------------------------------------------------------------------- - -stripLastByte :: ByteString -> ByteString -stripLastByte bs = BS.take (BS.length bs - 1) bs - -incrementBytes :: HasCallStack => ByteString -> ByteString -incrementBytes bs' = case BS.unsnoc bs' of - Nothing -> error ":/" - Just (bs, b) -> BS.snoc bs (b + 1) - -frMaxBoundPlusOne :: ByteString -frMaxBoundPlusOne = unsafe $ fromHex "01000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" - --- Constants (taken from Tezos tests mentioned at the top) ----------------------------------------------------------------------------- - -g1SomeVal :: ByteString -g1SomeVal = unsafe $ fromHex "026fcea34d1a4c5125142dfa3b616086309cab49e60e548d95de658af4d9329c269dc132bd5d884617e8767600daeee90c6f5d25f3d63540f3b799d291e5df4a90244346ed780d5c9d3afa8f3c9a196e089fa4edc4a9806592e8561d626579e3" - -g2SomeVal :: ByteString -g2SomeVal = unsafe $ fromHex "14e9b22683a66543ec447b7aa76e4404424709728507581d0b3f60a8062c3f7c7d3365197c59f7c961fa9731084f5be60d0a936e93d556bdef2032cdcae2fa9902dcbe105e01d7ab7126d83486d882c4efd2fc1ac55044157333be19acf0cb7a10bc41c8081c9babd8d5b41b645badd4a679b3d4e1b3ea2c0e1f53b39c00b3889a40306c9b9ee2da5831e90148334d91016474d07e0f4e36d2d51b5ca11b633b9a940b9c126aebf4a2537c18fdc6967fb677824bfa902157e53cb499a021e57b" - -frZeroValue :: ByteString -frZeroValue = unsafe $ fromHex "0000000000000000000000000000000000000000000000000000000000000000" - -g1ZeroValue :: ByteString -g1ZeroValue = unsafe $ fromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" - -g2ZeroValue :: ByteString -g2ZeroValue = unsafe $ fromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" - -frOneValue :: ByteString -frOneValue = unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000" - -g1OneValue :: ByteString -g1OneValue = unsafe $ fromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1" - -g2OneValue :: ByteString -g2OneValue = unsafe $ fromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801" - -frMinusOneValue :: ByteString -frMinusOneValue = unsafe $ fromHex "00000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73" - -g1MinusOneValue :: ByteString -g1MinusOneValue = unsafe $ fromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb114d1d6855d545a8aa7d76c8cf2e21f267816aef1db507c96655b9d5caac42364e6f38ba0ecb751bad54dcd6b939c2ca" - -g2MinusOneValue :: ByteString -g2MinusOneValue = unsafe $ fromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb813fa4d4a0ad8b1ce186ed5061789213d993923066dddaf1040bc3ff59f825c78df74f2d75467e25e0f55f8a00fa030ed0d1b3cc2c7027888be51d9ef691d77bcb679afda66c73f17f9ee3837a55024f78c71363275a75d75d86bab79f74782aa" diff --git a/morley-test/Test/Tezos/Crypto/Hash.hs b/morley-test/Test/Tezos/Crypto/Hash.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Crypto/Hash.hs +++ /dev/null @@ -1,61 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Tezos.Crypto.Hash'. - -module Test.Tezos.Crypto.Hash - ( test_Bytes_Hashing - ) where - -import Fmt (fmt, hexF) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Morley.Tezos.Crypto.Hash - -test_Bytes_Hashing :: [TestTree] -test_Bytes_Hashing = - [ testGroup "blake2b" $ hashingTest blake2b blake2bHashes - , testGroup "sha256" $ hashingTest sha256 sha256Hashes - , testGroup "sha512" $ hashingTest sha512 sha512Hashes - , testGroup "sha3" $ hashingTest sha3 sha3Hashes - , testGroup "keccak" $ hashingTest keccak keccakHashes - ] - --- These values have been computed using the following contract: -{- -parameter string; -storage bytes; -code { CDR; SHA512; # replace with desired function - NIL operation; PAIR;}; - --} - -blake2bHashes, sha256Hashes, sha512Hashes, sha3Hashes, keccakHashes :: [(ByteString, Text)] -blake2bHashes = - [ ("\0", "03170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c111314") -- 0x00 - , ("\0\0", "9ee6dfb61a2fb903df487c401663825643bb825d41695e63df8af6162ab145a6") -- 0x0000 - ] -sha256Hashes = - [ ("\0", "6e340b9cffb37a989ca544e6bb780a2c78901d3fb33738768511a30617afa01d") -- 0x00 - , ("\0\0", "96a296d224f285c67bee93c30f8a309157f0daa35dc5b87e410b78630a09cfc7") -- 0x0000 - ] -sha512Hashes = - [ ("\0", "b8244d028981d693af7b456af8efa4cad63d282e19ff14942c246e50d9351d22704a802a71c3580b6370de4ceb293c324a8423342557d4e5c38438f0e36910ee") -- 0x00 - , ("#", "d369286ac86b60fa920f6464d26becacd9f4c8bd885b783407cdcaa74fafd45a8b56b364b63f6256c3ceef26278a1c7799d4243a8149b5ede5ce1d890b5c7236") -- 0x23 - ] -sha3Hashes = - [ ("\0", "5d53469f20fef4f8eab52b88044ede69c77a6a68a60728609fc4a65ff531e7d0") -- 0x00 - , ("#", "415733a38975da5f451d27a3c42aa6ecb9b49e55466875b6c794606b7435083f") -- 0x23 - ] -keccakHashes = - [ ("\0", "bc36789e7a1e281436464229828f817d6612f7b477d66591ff96a9e064bcc98a") -- 0x00 - , ("#", "ace738c68088218d015fbdce138f062893d86818ac98932f7ce2907c5976fbde") -- 0x23 - ] - -hashingTest :: (ByteString -> ByteString) -> [(ByteString, Text)] -> [TestTree] -hashingTest hashFunc pairs = do - flip map pairs $ \(bs, bsHashHex) -> do - testCase ("correctly computes hash of 0x" <> fmt (hexF bs)) $ - fmt (hexF (hashFunc bs)) @?= bsHashHex diff --git a/morley-test/Test/Tezos/Crypto/Timelock.hs b/morley-test/Test/Tezos/Crypto/Timelock.hs deleted file mode 100644 --- a/morley-test/Test/Tezos/Crypto/Timelock.hs +++ /dev/null @@ -1,51 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Tezos.Crypto.Timelock'. -module Test.Tezos.Crypto.Timelock - ( test_ChestSerializationRoundtrip - , test_Chest - ) where - -import Prelude hiding (negate) - -import Hedgehog (forAll, property, withTests, (===)) -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.Crypto.Timelock -import Morley.Tezos.Crypto.Timelock -import Test.Cleveland.Util - -test_ChestSerializationRoundtrip :: [TestTree] -test_ChestSerializationRoundtrip = - [ roundtripTree (fst <$> genChestAndKey) chestBytes chestFromBytes - , roundtripTree (snd <$> genChestAndKey) chestKeyBytes chestKeyFromBytes - ] - -test_Chest :: [TestTree] -test_Chest = - [ testProperty "Chest value decodes" $ property do - ((chest, key), (payload, time)) <- forAll $ genChestAndKeyWithParams Nothing - openChest chest key time === Correct payload - -- the next test is pretty slow, so we halve the number of tests - , testProperty "Chest value doesn't decode with a wrong key" $ withTests 50 $ property do - time <- forAll $ genTLTime - ((chest, key), _) <- forAll $ genChestAndKeyWithParams (Just time) - ((chest', key'), _) <- - forAll . Gen.filter ((/= key) . snd . fst) $ genChestAndKeyWithParams (Just time) - openChest chest key' time === BogusOpening - openChest chest' key time === BogusOpening - , testProperty "Chest value doesn't decode with a bogus ciphertext" $ property do - ((Chest{..}, key), (_, time)) <- forAll $ genChestAndKeyWithParams Nothing - let Ciphertext{..} = chestCiphertext - payload' <- forAll . Gen.filter (/= ctPayload) $ Gen.bytes (Range.constant 100 500) - openChest Chest{chestCiphertext=Ciphertext{ctPayload = payload', ..}, ..} key time - === BogusCipher - , testProperty "Chest value doesn't decode with a wrong time" $ property do - ((chest, key), (_, time)) <- forAll $ genChestAndKeyWithParams Nothing - time' <- forAll . Gen.filter (/= time) $ genTLTime - openChest chest key time' === BogusOpening - ] diff --git a/morley-test/Test/Typeable.hs b/morley-test/Test/Typeable.hs deleted file mode 100644 --- a/morley-test/Test/Typeable.hs +++ /dev/null @@ -1,34 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on 'Morley.Util.Typeable'. -module Test.Typeable - ( test_castIgnoringPhantom - ) where - -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) - -import Morley.Util.Typeable - -data Some = forall x. Typeable x => Some x - -data MyType (a :: Type) = MyType Int - deriving stock (Show, Eq) - -data MyType' (a :: Type) = MyType' Double - deriving stock (Show, Eq) - -test_castIgnoringPhantom :: [TestTree] -test_castIgnoringPhantom = - [ testGroup "Simple type" - [ testCase "Can cast normal" $ - case (Some $ MyType @Integer 5) of - Some x -> castIgnoringPhantom x @?= Just (MyType 5) - - , testCase "Cast fails on mismatch" $ - case (Some $ MyType @Integer 5) of - Some x -> castIgnoringPhantom @MyType' x @?= Nothing - ] - ] diff --git a/morley-test/Test/Typecheck.hs b/morley-test/Test/Typecheck.hs deleted file mode 100644 --- a/morley-test/Test/Typecheck.hs +++ /dev/null @@ -1,379 +0,0 @@ --- 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 - , test_srcPosition - , unit_Unreachable_code - , test_Roundtrip - , test_StackRef - , test_TCTypeError_display - , hprop_ValueSeq_as_list - , test_SELF - , test_Value_contract - , test_Nested_Sequences - , test_Views - ) where - -import Data.Default (def) -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 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) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.Hedgehog (testProperty) - -import Hedgehog.Gen.Michelson.Typed -import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..), srcPos) -import Morley.Michelson.Parser (MichelsonSource(..), utypeQ) -import Morley.Michelson.Runtime (prepareContractExt) -import Morley.Michelson.Text (MText) -import Morley.Michelson.TypeCheck -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) - -import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts, inContractsDir) - -unit_Good_contracts :: Assertion -unit_Good_contracts - = mapM_ (\f -> do checkFile True f def{ tcVerbose = True } (const pass) - checkFile True f def (const pass)) - =<< getWellTypedContracts - -unit_Bad_contracts :: Assertion -unit_Bad_contracts - = mapM_ (\f -> do checkFile False f def{ tcVerbose = True } (const pass) - checkFile False f def (const pass)) - =<< getIllTypedContracts - -pattern IsSrcPos :: Word -> Word -> InstrCallStack -pattern IsSrcPos l c <- InstrCallStack [] (SrcPos (Pos l) (Pos c)) - -test_srcPosition :: [TestTree] -test_srcPosition = - [ testCase "Verify instruction position in a typecheck error" $ do - checkIllFile (inContractsDir "ill-typed/basic3.tz") $ \case - TCFailedOnInstr (Un.CONS _) _ (IsSrcPos 8 6) _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack3.mtz") $ \case - TCFailedOnInstr Un.DROP _ (IsSrcPos 10 17) _ (Just NotEnoughItemsOnStack) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack2.mtz") $ \case - TCExtError _ (IsSrcPos 9 2) (TestAssertError _) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/macro_in_let_fail.mtz") $ \case - TCFailedOnInstr (Un.COMPARE _) _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 7) (Pos 6))) _ - (Just (TypeEqError _)) -> True - _ -> False - checkIllFile (inContractsDir "ill-typed/compare_annotation_mismatch.tz") $ \case - TCFailedOnInstr (Un.COMPARE _) _ _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_map_update.tz") $ \case - TCFailedOnInstr (Un.UPDATE _) (SomeHST (_ ::& _ ::& (T.NTMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_map_get.tz") $ \case - TCFailedOnInstr (Un.GET _) (SomeHST (_ ::& (T.NTMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_map_mem.tz") $ \case - TCFailedOnInstr (Un.MEM _) (SomeHST (_ ::& (T.NTMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_big_map_update.tz") $ \case - TCFailedOnInstr (Un.UPDATE _) (SomeHST (_ ::& _ ::& (T.NTBigMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_big_map_get.tz") $ \case - TCFailedOnInstr (Un.GET _) (SomeHST (_ ::& (T.NTBigMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_big_map_mem.tz") $ \case - TCFailedOnInstr (Un.MEM _) (SomeHST (_ ::& (T.NTBigMap{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_set_update.tz") $ \case - TCFailedOnInstr (Un.UPDATE _) (SomeHST (_ ::& _ ::& (T.NTSet{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - - checkIllFile (inContractsDir "ill-typed/annotation_mismatch_set_mem.tz") $ \case - TCFailedOnInstr (Un.MEM _) (SomeHST (_ ::& (T.NTSet{}, _, _) ::& SNil)) _ _ (Just (AnnError _)) -> True - _ -> False - ] - -checkFile - :: HasCallStack - => Bool - -> FilePath - -> TypeCheckOptions - -> (TCError -> Expectation) - -> Expectation -checkFile wellTyped file options onError = do - c <- prepareContractExt (Just file) - case typeCheckingWith options $ typeCheckContract c of - Left err - | wellTyped -> - expectationFailure $ - "Typechecker unexpectedly failed on \"" <> file <> - "\": " <> displayException err - | otherwise -> onError err - Right _ - | not wellTyped -> - assertFailure $ - "Typechecker unexpectedly considered \"" <> file <> "\" well-typed." - | otherwise -> pass - -checkIllFile :: FilePath -> (TCError -> Bool) -> Expectation -checkIllFile file check = checkFile False file def - \e -> if check e then pass else unexpected file e - where - unexpected f e = - expectationFailure $ "Unexpected typecheck error: " <> displayException e <> " in file: " <> f - -unit_Unreachable_code :: Assertion -unit_Unreachable_code = do - let file = inContractsDir "ill-typed/fail_before_nop.tz" - let ics = InstrCallStack [] (srcPos 7 13) - econtract <- readContract @'T.TUnit @'T.TUnit (MSFile file) <$> Utf8.readFile file - econtract @?= Left (CRETypeCheck (MSFile file) $ TCUnreachableCode ics (one $ Un.WithSrcEx ics $ Un.SeqEx [])) - -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ testGroup "Value" - [ roundtripValue @Integer genValueInt - , roundtripValue @Timestamp genValueTimestamp - , roundtripValue @PublicKey $ genValue @'T.TKey - , roundtripValue @Signature $ genValue @'T.TSignature - , roundtripValue @ChainId $ genValue @'T.TChainId - , roundtripValue @(Maybe MText) $ genValue @('T.TOption 'T.TString) - , roundtripValue @[Maybe Integer] $ genValueList $ genValue @('T.TOption 'T.TInt) - , roundtripValue @(Set Integer) $ genValue @('T.TSet 'T.TInt) - , roundtripValue @(Integer, MText) $ genValuePair genValueInt $ genValue @'T.TString - , roundtripValue @(Integer, (MText, Integer)) $ - genValuePair genValueInt $ genValuePair (genValue @'T.TString) genValueInt - , roundtripValue @(Either MText Integer) $ genValue @('T.TOr 'T.TString 'T.TInt) - , roundtripValue @(Map MText Bool) $ genValue @('T.TMap 'T.TString 'T.TBool) - , roundtripValue @Natural $ genValue @'T.TNat - , roundtripValue @MText $ genValue @'T.TString - , roundtripValue @ByteString $ genValue @'T.TBytes - , roundtripValue @Mutez genValueMutez - , roundtripValue @Bool $ genValue @'T.TBool - , roundtripValue @KeyHash genValueKeyHash - , roundtripValue @Address $ genValue @'T.TAddress - , roundtripValue @Bls12381Fr $ genValue @'T.TBls12381Fr - , roundtripValue @Bls12381G1 $ genValue @'T.TBls12381G1 - , roundtripValue @Bls12381G2 $ genValue @'T.TBls12381G2 - ] - ] - where - roundtripValue - :: forall (a :: Type). - ( Each [T.SingI, T.HasNoOp] '[T.ToT a] - , Typeable a - ) - => Gen (T.Value $ T.ToT a) - -> TestTree - roundtripValue gen = testGroup (show $ typeRep (Proxy @a)) - [ roundtripValue' @a T.untypeValue "Readable" gen - , roundtripValue' @a T.untypeValueOptimized "Optimized" gen - , roundtripValue' @a T.untypeValueHashable "Hashable" gen - ] - - roundtripValue' - :: forall (a :: Type). - Each [T.SingI, T.HasNoOp] '[T.ToT a] - => (T.Value $ T.ToT a -> Un.Value) - -> String - -> Gen (T.Value $ T.ToT a) - -> TestTree - roundtripValue' doUntype name genV = - testProperty name $ property $ do - val :: T.Value (T.ToT a) <- forAll $ genV - let uval = doUntype val - runTC = typeCheckingWith def . runTypeCheckIsolated . usingReaderT (def @InstrCallStack) - case runTC $ typeCheckValue uval of - Right got -> got === val - Left err -> failedTest $ - "Type check unexpectedly failed: " <> pretty err - -test_StackRef :: [TestTree] -test_StackRef = - [ testProperty "Typecheck fails when ref is out of bounds" $ property $ do - let instr = printStRef 2 - hst = stackEl ::& stackEl ::& SNil - case - typeCheckingWith def . runTypeCheckIsolated $ - typeCheckList [Un.WithSrcEx def $ Un.PrimEx instr] hst - of - Left err -> void $ evalNF err - Right _ -> failedTest "Typecheck unexpectedly succeded" - , testProperty "Typecheck time is reasonably bounded" $ - let hst = stackEl ::& SNil - run i = - case - typeCheckingWith def . runTypeCheckIsolated $ - typeCheckList [Un.WithSrcEx def $ Un.PrimEx (printStRef i)] hst - of - Left err -> err - Right _ -> error "Typecheck unexpectedly succeded" - -- Making code processing performance scale with code size looks like a - -- good property, so we'd like to avoid scenario when user tries to - -- access 100500-th element of stack and typecheck hangs as a result - in meanTimeUpperBoundPropNF (sec 1) run 100000000000 - ] - where - printStRef i = Un.EXT . Un.UPRINT $ Un.PrintComment [Right (Un.StackRef i)] - stackEl = (T.starNotes @'T.TUnit, T.Dict, noAnn) - -test_TCTypeError_display :: [TestTree] -test_TCTypeError_display = - -- One may say that it's madness to write tests on 'Buildable' instances, - -- but IMO (martoon) it's worth resulting duplication because tests allow - -- avoiding silly errors like lost spaces and ensuring general sanity - -- of used way to display content. - [ testCase "TypeEqError" $ - build (TypeEqError MkMismatchError{meActual=T.TUnit, meExpected=T.TKey}) - @?= [itu| - Types not equal: - Expected: key - Actual: unit - |] - - , testCase "StackEqError" $ - 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) - @?= "Type 'big_map int int' is unsupported here because it has 'big_map'" - - , testCase "InvalidValueType" $ - build (InvalidValueType T.TUnit) - @?= "Value type is never a valid `unit`" - ] - -hprop_ValueSeq_as_list :: Property -hprop_ValueSeq_as_list = property $ do - l <- forAll $ Gen.nonEmpty (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000)) - let - untypedValue = Un.ValueSeq $ Un.ValueInt <$> l - typedValue = T.VList $ T.VInt <$> toList l - runTypeCheckInstr = typeCheckingWith def . runTypeCheckIsolated . usingReaderT def - runTypeCheckInstr (typeCheckValue untypedValue) === Right typedValue - -test_Nested_Sequences :: [TestTree] -test_Nested_Sequences = - let - runTC = typeCheckingWith def . runTypeCheckIsolated . usingReaderT (def @InstrCallStack) - illTypedList = Un.ValueLambda $ Un.SeqEx [Un.SeqEx []] :| [Un.SeqEx []] - wellTypedList = Un.ValueLambda $ Un.SeqEx [] :| [Un.SeqEx []] - wellTypedLambda = Un.ValueSeq $ Un.ValueSeq (Un.ValueNil :| []) :| [Un.ValueNil] - in - [ 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: " <> 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: " <> 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: " <> pretty err - ] - -test_SELF :: [TestTree] -test_SELF = - [ testCase "Entrypoint not present" $ - checkFile False (inContractsDir "ill-typed/self-bad-entrypoint.mtz") def $ - \case - TCFailedOnInstr Un.SELF{} _ _ _ (Just EntrypointNotFound{}) -> pass - other -> assertFailure $ "Unexpected error: " <> pretty other - - , testCase "Entrypoint type mismatch" $ - checkFile False (inContractsDir "ill-typed/self-entrypoint-type-mismatch.mtz") - def (const pass) - - , testCase "Entrypoint can be found" $ - checkFile True (inContractsDir "entrypoints/self1.mtz") def - (const pass) - ] - -test_Value_contract :: [TestTree] -test_Value_contract = - [ testCase "No contract exists" $ - case typeCheckingWith def $ - typeVerifyParameter @('T.TContract 'T.TUnit) mempty addrUVal1 - of - Left (TCFailedOnValue _ _ _ _ (Just (UnknownContract _))) -> pass - 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: " <> 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: " <> either pretty pretty res - ] - where - addr1' = mkContractHashHack "123" - 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', - unsafe . mkSomeParamType - $ ParameterType [utypeQ| or (nat %s) (int %q) |] noAnn - ) - ] - -test_Views :: [TestTree] -test_Views = - [ testCase "Duplicated name" $ do - checkIllFile (inContractsDir "ill-typed/duplicated_view_name.tz") \case - TCContractError "Duplicated view name 'add'" _ -> True - _ -> False - - , testCase "Fully duplicated view" $ do - checkIllFile (inContractsDir "ill-typed/duplicated_view_full.tz") \case - TCContractError "Duplicated view name 'add'" _ -> True - _ -> False - - ] diff --git a/morley-test/Test/Typecheck/Annotation.hs b/morley-test/Test/Typecheck/Annotation.hs deleted file mode 100644 --- a/morley-test/Test/Typecheck/Annotation.hs +++ /dev/null @@ -1,106 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Typecheck.Annotation - ( test_variableAnnotations - ) where - -import Data.Vinyl (Rec(..)) -import Test.HUnit ((@?=)) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase) - -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 () -import Test.Cleveland.Michelson.Import (importContract) -import Test.Util.Contracts (inContractsDir, ()) - -test_variableAnnotations :: [TestTree] -test_variableAnnotations = - [ testCase "Annotations are preserved in cadr_annotation.tz" $ do - let file = inContractsDir ("tezos_examples" "attic" "cadr_annotation.tz") - param = "param" - no_name = "no_name" - name = "name" - contract <- - importContract @('TPair ('TPair 'TUnit 'TString) 'TBool) @'TUnit file - stripVarAnn (cCode contract) @?= - loc 2 7 (withNotes [notes|pair (pair %p1 unit (string %no_name)) bool|] (AnnCAR param noAnn)) - `Seq` Nested ( - 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 - `Seq` loc 2 52 NIL - `Seq` loc 2 67 (AnnPAIR noAnn noAnn noAnn) - - , testCase "Annotations are preserved in pexec_2.tz" $ do - let file = inContractsDir ("tezos_examples" "opcodes" "pexec_2.tz") - contract <- - importContract @'TInt @('TList 'TInt) file - stripVarAnn (cCode contract) @?= - AnnUNPAIR "p" "s" "" "" - `Seq` loc 4 6 (LAMBDA (VLam (RfNormal ( - AnnUNPAIR "" "" "" "" - `Seq` loc 5 24 (DIP (AnnUNPAIR "" "" "" "")) - `Seq` loc 5 41 ADD - `Seq` loc 5 47 MUL)))) - `Seq` loc 6 6 SWAP - `Seq` loc 6 13 APPLY - `Seq` loc 7 6 (PUSH (VInt 3)) - `Seq` loc 7 19 APPLY - `Seq` loc 8 6 SWAP - `Seq` loc 8 13 (MAP (loc 8 19 (DIP (loc 8 25 DUP)) - `Seq` loc 8 33 EXEC)) - `Seq` loc 9 6 (DIP (loc 9 12 DROP)) - `Seq` loc 10 6 NIL - `Seq` loc 10 21 (AnnPAIR noAnn noAnn noAnn) - - -- Regression test: - , testCase "UNPAPAIR macro generates UNPAIR instructions without annotations" $ do - let file = inContractsDir "unpair_macro_simple.tz" - a1 = "a1"; a2 = "a2"; a3 = "a3" - u1 = "u1"; u2 = "u2"; u3 = "u3" - y1 = "y1"; y2 = "y2" - contract <- importContract @'TUnit @'TUnit file - stripVarAnn (cCode contract) @?= - loc 2 7 DROP - `Seq` loc 3 7 (withNotes (NTUnit u3) (withVN a3 UNIT)) - `Seq` loc 3 21 (withNotes (NTUnit u2) (withVN a2 UNIT)) - `Seq` loc 3 35 (withNotes (NTUnit u1) (withVN a1 UNIT)) - `Seq` withNotes (NTPair noAnn y1 noAnn a1 noAnn (NTUnit u1) (NTPair noAnn y2 noAnn a2 a3 (NTUnit u2) (NTUnit u3))) (Nested ( - withNotes (NTUnit u1) (DIP ( - withNotes (NTPair noAnn y2 noAnn a2 a3 (NTUnit u2) (NTUnit u3)) (AnnPAIR noAnn y2 noAnn))) - `Seq` withNotes (NTPair noAnn y1 noAnn a1 noAnn (NTUnit u1) (NTPair noAnn y2 noAnn a2 a3 (NTUnit u2) (NTUnit u3))) (withVN "q" (AnnPAIR noAnn y1 noAnn)))) - `Seq` - withNotes (NTUnit u1) - ( Nested - ( InstrWithNotes Proxy - (NTUnit u1 :& NTPair noAnn y2 noAnn a2 a3 (NTUnit u2) (NTUnit u3) :& RNil) - UNPAIR - `Seq` - DIP UNPAIR - ) - ) - `Seq` loc 5 7 (withNotes (NTUnit noAnn) (DIP ( - loc 5 13 (withNotes (NTUnit noAnn) DROP) - `Seq` (loc 5 19 DROP)))) - `Seq` loc 5 27 NIL - `Seq` loc 5 42 (withNotes (NTPair noAnn noAnn noAnn noAnn noAnn (NTList noAnn (NTOperation noAnn)) (NTUnit noAnn)) (AnnPAIR noAnn noAnn noAnn)) - ] - where - loc :: Word -> Word -> Instr a b -> Instr a b - loc row col = WithLoc (InstrCallStack [] (srcPos row col)) - - withNotes n = InstrWithNotes Proxy (n :& RNil) - - withVN vn = InstrWithVarNotes (one vn) - - stripVarAnn :: Instr a b -> Instr a b - stripVarAnn = dfsModifyInstr def \case - InstrWithVarAnns _ i -> i - i -> i diff --git a/morley-test/Test/Untyped/Instr.hs b/morley-test/Test/Untyped/Instr.hs deleted file mode 100644 --- a/morley-test/Test/Untyped/Instr.hs +++ /dev/null @@ -1,46 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests for 'Morley.Michelson.Untyped.Instr'. - -module Test.Untyped.Instr - ( unit_Flattening - ) where - -import Test.HUnit (Assertion, (@?=)) - -import Morley.Michelson.Untyped.Instr - -unit_Flattening :: Assertion -unit_Flattening = flattenExpandedOp sampleOp @?= expectedInstrs - where - sampleOp :: ExpandedOp - sampleOp = SeqEx - [ toSeq [] - , toSeq seq1 - , toPrim prim3 - ] - - toPrim :: ExpandedInstr -> ExpandedOp - toPrim = PrimEx - toSeq :: [ExpandedInstr] -> ExpandedOp - toSeq = SeqEx . map PrimEx - - seq1 = [prim1, prim2] - prim1 = DROP - prim2 = SWAP - prim3 = DIP - [ toPrim prim1 - , toSeq seq1 - , toSeq seq1 - , toSeq [] - , SeqEx [toSeq seq1, toSeq seq1] - ] - - expectedInstrs :: [ExpandedInstr] - expectedInstrs = - [ prim1 - , prim2 - , DIP $ map toPrim $ - prim1 : mconcat (replicate 4 seq1) - ] diff --git a/morley-test/Test/Util/HUnit.hs b/morley-test/Test/Util/HUnit.hs deleted file mode 100644 --- a/morley-test/Test/Util/HUnit.hs +++ /dev/null @@ -1,18 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - --- | Helpers for HUnit. - -module Test.Util.HUnit - ( assertEqualBuild - ) where - -import Test.HUnit (Assertion, assertEqual) -import Test.Util.Hedgehog (ShowThroughBuild(..)) - -assertEqualBuild - :: (HasCallStack, Eq a, Show (ShowThroughBuild a)) - => String -> a -> a -> Assertion -assertEqualBuild desc a b = - assertEqual desc (STB a) (STB b) diff --git a/morley-test/Test/Util/Hedgehog.hs b/morley-test/Test/Util/Hedgehog.hs deleted file mode 100644 --- a/morley-test/Test/Util/Hedgehog.hs +++ /dev/null @@ -1,92 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{- -Copyright (c) 2017 IOHK - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. --} - --- | Testing utilities to be used with Hedgehog - -module Test.Util.Hedgehog - ( ShowThroughBuild (..) - - -- * Roundtrip properties - , roundtripTree - , roundtripTreeSTB - , aesonRoundtrip - ) where - -import Debug qualified (show) - -import Data.Aeson (FromJSON(..), ToJSON(..)) -import Data.Aeson qualified as Aeson -import Fmt (Buildable, pretty) -import Hedgehog (Gen) -import Test.Tasty (TestTree) -import Text.Show qualified (show) - -import Test.Cleveland.Util (roundtripTree) - ----------------------------------------------------------------------------- --- 'Show'ing a value though 'Buildable' type class. --- Useful because Hedgehog uses 'Show'. ----------------------------------------------------------------------------- - -newtype ShowThroughBuild a = STB - { unSTB :: a - } deriving newtype (Eq, Ord) - -instance {-# OVERLAPPABLE #-} Buildable a => Show (ShowThroughBuild a) where - show = pretty . unSTB - -instance Show (ShowThroughBuild ByteString) where - show = Debug.show . unSTB - -genShowThroughBuild :: Gen a -> Gen (ShowThroughBuild a) -genShowThroughBuild genA = STB <$> genA - - ----------------------------------------------------------------------------- --- Roundtrip ----------------------------------------------------------------------------- - --- | Version of 'roundtripTree' which shows values using 'Buildable' instance. -roundtripTreeSTB - :: forall x y err. - ( Show (ShowThroughBuild x) - , Show y - , Show (ShowThroughBuild err) - , Typeable x - , Eq x - , Eq err - ) - => Gen x - -> (x -> y) - -> (y -> Either err x) - -> TestTree -roundtripTreeSTB genX xToY yToX = roundtripTree (genShowThroughBuild genX) (xToY . unSTB) (bimap STB STB . yToX) - -aesonRoundtrip - :: forall x. - (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Eq x) - => Gen x -> TestTree -aesonRoundtrip genX = roundtripTreeSTB genX (Aeson.encode @x) Aeson.eitherDecode diff --git a/morley-test/Test/Util/Parser.hs b/morley-test/Test/Util/Parser.hs deleted file mode 100644 --- a/morley-test/Test/Util/Parser.hs +++ /dev/null @@ -1,27 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module Test.Util.Parser - ( shouldParse - ) where - -import Fmt (build, indentF, pretty, unlinesF) -import Test.HUnit.Base (assertFailure) -import Text.Megaparsec (errorBundlePretty) - -import Morley.Michelson.Parser (Parser, codeSrc) -import Morley.Michelson.Parser qualified as Parser - --- | Expect the given text to be successfully parsed. -shouldParse :: HasCallStack => Parser () a -> Text -> IO a -shouldParse parser text = - case Parser.parseNoEnv parser codeSrc text of - Left err -> - assertFailure . pretty $ unlinesF - [ "Failed to parse:" - , indentF 2 $ build text - , "Error:" - , indentF 2 $ build $ errorBundlePretty err - ] - Right res -> return res -infix 2 `shouldParse` diff --git a/morley-test/Test/Util/TH.hs b/morley-test/Test/Util/TH.hs deleted file mode 100644 --- a/morley-test/Test/Util/TH.hs +++ /dev/null @@ -1,78 +0,0 @@ --- 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 deleted file mode 100644 --- a/morley-test/Test/ValConversion.hs +++ /dev/null @@ -1,74 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Testing of toVal / fromVal conversions - -module Test.ValConversion - ( test_Roundtrip - , unit_toVal - ) where - -import Hedgehog (Gen) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import Test.HUnit (Assertion, (@?)) -import Test.Tasty (TestTree) - -import Morley.Michelson.Text -import Morley.Michelson.Typed (IsoValue(..), ToT, Value, Value'(..)) -import Test.Cleveland.Instances () -import Test.Cleveland.Util (genTuple2) - -import Test.Util.Hedgehog (roundtripTree) - - --- | TestTrees to test toVal / fromVal conversions (roundtrip) -test_Roundtrip :: [TestTree] -test_Roundtrip = - [ roundtrip @Integer genInteger - , roundtrip @Bool Gen.bool - , roundtrip @[Bool] $ Gen.list (Range.linear 0 100) Gen.bool - , roundtrip @(Maybe Integer) $ Gen.maybe genInteger - , roundtrip @(Maybe (Maybe Integer)) $ Gen.maybe (Gen.maybe genInteger) - , roundtrip @(Either Bool Integer) $ Gen.either Gen.bool genInteger - , roundtrip @(Set Integer) $ Gen.set (Range.linear 0 100) genInteger - , roundtrip @(Set Bool) $ Gen.set (Range.linear 0 2) Gen.bool - , roundtrip @(Map Integer Integer) $ Gen.map (Range.linear 0 100) (genTuple2 genInteger genInteger) - , roundtrip @(Map Integer Bool) $ Gen.map (Range.linear 0 100) (genTuple2 genInteger Gen.bool) - , roundtrip @(Map Integer (Maybe (Either Bool Bool))) $ - Gen.map (Range.linear 0 100) $ - genTuple2 - genInteger - (Gen.maybe (Gen.either Gen.bool Gen.bool)) - ] - where - genInteger = Gen.integral (Range.linearFrom 0 (fromIntegral $ minBound @Int64) (fromIntegral $ maxBound @Word64)) - - roundtrip :: forall a. - (Show a, Eq a, Typeable a, IsoValue a) => Gen a -> TestTree - roundtrip genA = roundtripTree @a @_ @Void genA toVal (Right . fromVal) - -unit_toVal :: Assertion -unit_toVal = do - check () $ (\case VUnit -> True;) - check (10 :: Integer) $ (\case (VInt 10) -> True; _ -> False) - check ("abc" :: ByteString) $ (\case (VBytes "abc") -> True; _ -> False) - check (Just "abc" :: Maybe ByteString) - $ (\case (VOption (Just (VBytes "abc"))) -> True; _ -> False) - check (Left "abc" :: Either ByteString ByteString) - $ (\case (VOr (Left (VBytes "abc"))) -> True; _ -> False) - check (Left "abc" :: Either ByteString Integer) - $ (\case (VOr (Left (VBytes "abc"))) -> True; _ -> False) - check ((10, "abc") :: (Integer, ByteString)) - $ (\case (VPair ((VInt 10), VBytes "abc")) -> True; _ -> False) - check (["abc", "cde"] :: [ByteString]) - $ (\case (VList [ VBytes "abc" - , VBytes "cde"]) -> True; _ -> False) - check @Integer 10 (\case (VInt 10) -> True; _ -> False) - check @Integer (-10) (\case (VInt (-10)) -> True; _ -> False) - check @Natural 10 (\case (VNat 10) -> True; _ -> False) - check ("abc" :: MText) (\case (VString "abc") -> True; _ -> False) - check True (\case (VBool True) -> True; _ -> False) - where - check :: IsoValue a => a -> (Value (ToT a) -> Bool) -> Assertion - check v p = p (toVal v) @? "toVal returned unexpected result" diff --git a/morley-test/Test/Views.hs b/morley-test/Test/Views.hs deleted file mode 100644 --- a/morley-test/Test/Views.hs +++ /dev/null @@ -1,77 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Tests on views-related primitives. -module Test.Views - ( test_ViewsSets - ) where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) - -import Morley.Michelson.Typed - -dummyViewCode :: Integer -> ViewCode arg st arg -dummyViewCode id' = CAR :# PUSH (VInt id') :# DROP - -dummyView :: HasCallStack => Text -> Integer -> View 'TUnit 'TUnit 'TUnit -dummyView name id' = View - { vName = unsafe $ mkViewName name - , vArgument = starNotes - , vReturn = starNotes - , vCode = dummyViewCode id' - } - -dummySomeView :: HasCallStack => Text -> Integer -> SomeView 'TUnit -dummySomeView = SomeView ... dummyView - -test_ViewsSets :: TestTree -test_ViewsSets = testGroup "Views sets" - [ testGroup "Instant construction" - [ testCase "Can create views set with constructor" $ - assertBool "Failed to construct" $ - mkViewsSet [dummySomeView "a" 1, dummySomeView "b" 2] - & isRight - - , testCase "Duplicate views cause failure" $ - mkViewsSet [dummySomeView "a" 1, dummySomeView "b" 2, dummySomeView "a" 3] - @?= Left (DuplicatedViewName (unsafe $ mkViewName "a")) - - ] - - , testGroup "Incremental construction" - [ testCase "Can incrementally build views set" $ - assertBool "Failed to construct" $ - pure emptyViewsSet - >>= addViewToSet (dummyView "a" 1) - >>= addViewToSet (dummyView "b" 2) - & isRight - - , testCase "Duplicate views cause failure" $ - ( pure emptyViewsSet - >>= addViewToSet (dummyView "a" 1) - >>= addViewToSet (dummyView "b" 2) - >>= addViewToSet (dummyView "a" 3) - ) @?= Left (DuplicatedViewName (unsafe $ mkViewName "a")) - - ] - - , testGroup "Lookup" - let viewsSet1 = unsafe $ mkViewsSet - [ dummySomeView "" 0 - , dummySomeView "a" 1 - ] - in - [ testCase "Can find a present view" $ do - lookupView (unsafe $ mkViewName "") viewsSet1 - @?= Just (dummySomeView "" 0) - lookupView (unsafe $ mkViewName "a") viewsSet1 - @?= Just (dummySomeView "a" 1) - - , testCase "Fail to find a non-existent view" $ - lookupView (unsafe $ mkViewName "x") viewsSet1 - @?= Nothing - - ] - - ] diff --git a/morley-test/Tree.hs b/morley-test/Tree.hs deleted file mode 100644 --- a/morley-test/Tree.hs +++ /dev/null @@ -1,5 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} 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 @@ -9,34 +9,37 @@ , genMText ) where - import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen +import Hedgehog.Range (Range) import Hedgehog.Range qualified as Range import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, mkMText) +import Hedgehog.Range.Defaults + genInstrCallStack :: MonadGen m => m InstrCallStack genInstrCallStack = InstrCallStack <$> genLetCallStack <*> genSrcPos where genLetCallStack = Gen.frequency [ (80, pure []) - , (18, Gen.list (Range.singleton 1) genLetName) - , (2, Gen.list (Range.singleton 2) genLetName) + , (18, Gen.list (Range.singleton 1) $ genLetName def) + , (2, Gen.list (Range.singleton 2) $ genLetName def) ] -genLetName :: MonadGen m => m LetName -genLetName = LetName <$> Gen.text (Range.linear 0 3) Gen.unicodeAll +genLetName :: MonadGen m => Range TinyLength -> m LetName +genLetName lenRange = + LetName <$> Gen.text (unTinyLength <$> lenRange) Gen.unicodeAll genSrcPos :: MonadGen m => m SrcPos -genSrcPos = SrcPos <$> genPos <*> genPos +genSrcPos = SrcPos <$> genPos def <*> genPos def -genPos :: MonadGen m => m Pos -genPos = Pos <$> Gen.word Range.linearBounded +genPos :: MonadGen m => Range.Range Pos -> m Pos +genPos range = Pos <$> Gen.word (unPos <$> range) -genMText :: MonadGen m => m MText -genMText = +genMText :: MonadGen m => Range.Range Length -> m MText +genMText lenRange = unsafe . mkMText <$> Gen.text - (Range.linear 0 100) + (unLength <$> lenRange) (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 @@ -6,14 +6,19 @@ module Hedgehog.Gen.Michelson.Typed ( genBigMap , genEpAddress - , genValueKeyHash - , genValueMutez + , genValueBigMap + , genValueChestAndKey , genValueInt + , genValueKeyHash , genValueList - , genValueUnit + , genValueMap + , genValueMutez + , genValueNat , genValuePair + , genValueSet + , genValueString , genValueTimestamp - , genValueChestAndKey + , genValueUnit , genValue , genValue' @@ -25,6 +30,7 @@ import Data.Singletons (Sing) import Hedgehog (GenBase, MonadGen) import Hedgehog.Gen qualified as Gen +import Hedgehog.Range (Range) import Hedgehog.Range qualified as Range import Hedgehog.Gen.Michelson.Untyped (genEpName) @@ -39,43 +45,90 @@ import Morley.Michelson.Typed.Haskell.Value (BigMap(..), BigMapId(..), ToT, WellTypedToT) import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Value (RemFail(..)) +import Morley.Tezos.Core (Mutez, Timestamp) import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Hedgehog.Gen.Tezos.Crypto.Timelock (genChestAndKey) +import Hedgehog.Range.Defaults genBigMap :: forall k v m. (MonadGen m, Ord k, WellTypedToT k, WellTypedToT v, Comparable (ToT k)) - => m k -> m v -> m (BigMap k v) -genBigMap genK genV = + => Range Length -> m k -> m v -> m (BigMap k v) +genBigMap rangeLen genK genV = BigMap <$> Gen.maybe (fmap BigMapId genBigMapId) - <*> Gen.map (Range.linear 0 100) (liftA2 (,) genK genV) + <*> Gen.map (unLength <$> rangeLen) (liftA2 (,) genK genV) +genValueMap + :: forall (k :: T) (v :: T) m instr. + (MonadGen m, WellTyped k, WellTyped v, Comparable k) + => Range Length -> m (Value' instr k) -> m (Value' instr v) -> m (Value' instr ('TMap k v)) +genValueMap len genKey genVal = + VMap <$> Gen.map (unLength <$> len) (liftA2 (,) genKey genVal) + +genValueBigMap + :: forall (k :: T) (v :: T) m instr. + (MonadGen m, WellTyped k, WellTyped v, HasNoBigMap v, Comparable k) + => Range Length -> m (Value' instr k) -> m (Value' instr v) -> m (Value' instr ('TBigMap k v)) +genValueBigMap len genKey genVal = + VBigMap + <$> Gen.maybe genBigMapId + <*> Gen.map (unLength <$> len) (liftA2 (,) genKey genVal) + genEpAddress :: (MonadGen m, GenBase m ~ Identity) => m EpAddress genEpAddress = EpAddress <$> genAddress <*> genEpName genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash) genValueKeyHash = VKeyHash <$> genKeyHash -genValueMutez :: MonadGen m => m (Value' instr 'TMutez) -genValueMutez = VMutez <$> genMutez +genValueMutez :: MonadGen m => Range Mutez -> m (Value' instr 'TMutez) +genValueMutez = fmap VMutez . genMutez -genValueInt :: MonadGen m => m (Value' instr 'TInt) -genValueInt = VInt <$> Gen.integral (Range.linearFrom 0 -1000 1000) +genValueInt :: MonadGen m => Range (Value' instr 'TInt) -> m (Value' instr 'TInt) +genValueInt range = VInt <$> Gen.integral (unVal <$> range) + where + unVal :: Value' instr 'TInt -> Integer + unVal (VInt val) = val -genValueList :: (MonadGen m, SingI a) => m (Value' instr a) -> m (Value' instr ('TList a)) -genValueList genA = VList <$> Gen.list (Range.linear 0 100) genA +genValueNat :: MonadGen m => Range (Value' instr 'TNat) -> m (Value' instr 'TNat) +genValueNat range = VNat <$> Gen.integral (unVal <$> range) + where + unVal :: Value' instr 'TNat -> Natural + unVal (VNat val) = val +genValueString :: MonadGen f => Range Length -> f (Value' instr 'TString) +genValueString rangeLen = + VString . unsafe. mkMText . fromString <$> Gen.string (unLength <$> rangeLen) Gen.alphaNum + +genValueBytes :: MonadGen f => Range Length -> f (Value' instr 'TBytes) +genValueBytes rangeLen = VBytes <$> Gen.bytes (unLength <$> rangeLen) + +genValueList + :: (MonadGen m, SingI a) => Range Length -> m (Value' instr a) -> m (Value' instr ('TList a)) +genValueList rangeLen genA = VList <$> Gen.list (unLength <$> rangeLen) genA + +genValueSet + :: (MonadGen m, Comparable a, SingI a) + => Range Length -> m (Value' instr a) -> m (Value' instr ('TSet a)) +genValueSet rangeLen genA = VSet <$> Gen.set (unLength <$> rangeLen) genA + genValueUnit :: Applicative m => m (Value' instr 'TUnit) genValueUnit = pure VUnit -genValuePair :: MonadGen m => m (Value' instr a) -> m (Value' instr b) -> m (Value' instr ('TPair a b)) +genValuePair + :: MonadGen m => m (Value' instr a) -> m (Value' instr b) -> m (Value' instr ('TPair a b)) genValuePair genA genB = VPair ... (,) <$> genA <*> genB -genValueTimestamp :: MonadGen m => m (Value' instr 'TTimestamp) -genValueTimestamp = VTimestamp <$> genTimestamp +genValueTimestamp :: MonadGen m => Range Timestamp -> m (Value' instr 'TTimestamp) +genValueTimestamp = fmap VTimestamp . genTimestamp +genValueTicket + :: (MonadGen m, Comparable a) + => Range TicketAmount -> m (Value' instr a) -> m (Value' instr ('TTicket a)) +genValueTicket range genVal = VTicket <$> genAddress <*> genVal + <*> Gen.integral (unTicketAmount <$> range) + genValueChestAndKey :: MonadGen m => m (Value' instr 'TChest, Value' instr 'TChestKey) genValueChestAndKey = bimap VChest VChestKey <$> genChestAndKey @@ -115,14 +168,12 @@ , VOption . Just <$> genValue' st ] STList (STPair STBls12381G1 STBls12381G2) -> genBls12Pairing - STList st -> VList <$> Gen.list (Range.linear 0 100) (genValue' st) - STSet st -> VSet <$> Gen.set (Range.linear 0 100) (genValue' st) + STList st -> genValueList def $ genValue' st + STSet st -> genValueSet def $ genValue' st STContract (s :: SingT p) -> case (checkOpPresence s, checkNestedBigMapsPresence s) of (OpAbsent, NestedBigMapsAbsent) -> VContract <$> genAddress <*> pure unsafeSepcCallRoot _ -> Gen.discard - STTicket (s :: SingT p) -> - VTicket <$> genAddress <*> genValue' s - <*> Gen.integral (Range.linearFrom 0 0 1000) + STTicket (s :: SingT p) -> genValueTicket def $ genValue' s STPair STChestKey STChest -> VPair . bimap VChestKey VChest . swap <$> genChestAndKey STPair l r -> VPair <$> ((,) <$> genNoOpValue l <*> genNoOpValue r) STOr l r -> VOr <$> Gen.choice @@ -132,23 +183,19 @@ -- It's quite hard to generate proper lambda of given type, so it always returns FAILWITH. -- Such implementation is sufficient for now. STLambda{} -> pure $ VLam $ RfAlwaysFails $ Seq UNIT FAILWITH - STMap k v -> - VMap <$> Gen.map (Range.linear 0 100) (liftA2 (,) (genNoOpValue k) (genNoOpValue v)) - STBigMap k v -> - VBigMap - <$> Gen.maybe genBigMapId - <*> Gen.map (Range.linear 0 100) (liftA2 (,) (genNoOpValue k) (genNoOpValue v)) - STInt -> genValueInt - STNat -> VNat <$> Gen.integral (Range.linearFrom 0 0 1000) - STString -> VString . unsafe . mkMText . fromString <$> Gen.string (Range.linear 0 100) Gen.alphaNum - STBytes -> VBytes <$> Gen.bytes (Range.linear 0 100) - STMutez -> genValueMutez + STMap k v -> genValueMap def (genNoOpValue k) (genNoOpValue v) + STBigMap k v -> genValueBigMap def (genNoOpValue k) (genNoOpValue v) + STInt -> genValueInt def + STNat -> genValueNat def + STString -> genValueString def + STBytes -> genValueBytes def + STMutez -> genValueMutez def STKeyHash -> genValueKeyHash STBls12381Fr -> VBls12381Fr <$> genBls12381Fr STBls12381G1 -> VBls12381G1 <$> genBls12381G1 STBls12381G2 -> VBls12381G2 <$> genBls12381G2 -- Note that we also have a special case for a list of BLS12 pairings - STTimestamp -> genValueTimestamp + STTimestamp -> genValueTimestamp def STAddress -> VAddress <$> genEpAddress STBool -> VBool <$> Gen.bool STChest -> VChest . fst <$> genChestAndKey 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 @@ -24,7 +24,6 @@ , genElt , genParameterType , genType - , genValidType , genEpName , genAnnotation , genT @@ -40,15 +39,16 @@ import Morley.Michelson.Untyped import Hedgehog.Gen.Michelson (genInstrCallStack, genMText) +import Hedgehog.Range.Defaults -genInternalByteString :: MonadGen m => m InternalByteString -genInternalByteString = InternalByteString <$> Gen.bytes (Range.linear 0 100) +genInternalByteString :: MonadGen m => Range Length -> m InternalByteString +genInternalByteString rangeLen = InternalByteString <$> Gen.bytes (unLength <$> rangeLen) genVar :: MonadGen m => m Var genVar = Var <$> genSmallText genTyVar :: (MonadGen m, GenBase m ~ Identity) => m TyVar -genTyVar = Gen.choice [VarID <$> genVar, TyCon <$> genValidType] +genTyVar = Gen.choice [VarID <$> genVar, TyCon <$> genType] genExpandedOp :: (MonadGen m, GenBase m ~ Identity) => m ExpandedOp genExpandedOp = Gen.recursive Gen.choice @@ -69,18 +69,20 @@ [ STACKTYPE <$> genStackTypePattern , FN <$> genSmallText <*> genStackFn <*> genSmallList genOp , UTEST_ASSERT <$> genTestAssert genOp - , UPRINT <$> genPrintComment + , UPRINT <$> genPrintComment def , UCOMMENT <$> genSmallText ] -genPrintComment :: MonadGen m => m PrintComment -genPrintComment = PrintComment <$> Gen.list (Range.linear 0 5) (Gen.either genSmallText genStackRef) +genPrintComment :: MonadGen m => Range TinyLength -> m PrintComment +genPrintComment rangeLen = PrintComment <$> Gen.list (unTinyLength <$> rangeLen) + (Gen.either genSmallText (genStackRef def)) -genStackRef :: MonadGen m => m StackRef -genStackRef = StackRef <$> Gen.integral (Range.linear 0 (fromIntegral $ maxBound @Word64)) +genStackRef :: MonadGen m => Range StackRef -> m StackRef +genStackRef range = StackRef <$> Gen.integral (unStackRef <$> range) + where unStackRef (StackRef x) = x genTestAssert :: MonadGen m => m op -> m (TestAssert op) -genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment <*> genSmallList genOp +genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment def <*> genSmallList genOp genStackFn :: (MonadGen m, GenBase m ~ Identity) => m StackFn genStackFn = StackFn @@ -100,7 +102,7 @@ instrAbstractWithOp :: (MonadGen m, GenBase m ~ Identity) => m op -> [m (InstrAbstract op)] instrAbstractWithOp genOp = [ EXT <$> genExtInstrAbstract genOp - , PUSH <$> genAnnotation <*> genValidType <*> genValue' genOp + , PUSH <$> genAnnotation <*> genType <*> genValue' genOp , IF_NONE <$> genSmallList genOp <*> genSmallList genOp , IF_LEFT <$> genSmallList genOp <*> genSmallList genOp , IF_CONS <$> genSmallList genOp <*> genSmallList genOp @@ -109,7 +111,7 @@ , IF <$> genSmallList genOp <*> genSmallList genOp , LOOP <$> genSmallList genOp , LOOP_LEFT <$> genSmallList genOp - , LAMBDA <$> genAnnotation <*> genValidType <*> genValidType <*> genSmallList genOp + , LAMBDA <$> genAnnotation <*> genType <*> genType <*> genSmallList genOp , DIP <$> genSmallList genOp , DIPN <$> Gen.word Range.linearBounded <*> genSmallList genOp , CREATE_CONTRACT <$> genAnnotation <*> genAnnotation <*> genContract' genOp @@ -125,21 +127,21 @@ , DIG <$> Gen.word Range.linearBounded , DUG <$> Gen.word Range.linearBounded , SOME <$> genAnnotation <*> genAnnotation - , NONE <$> genAnnotation <*> genAnnotation <*> genValidType + , NONE <$> genAnnotation <*> genAnnotation <*> genType , UNIT <$> genAnnotation <*> genAnnotation , PAIR <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation , PAIRN <$> genAnnotation <*> Gen.word Range.linearBounded , UNPAIRN <$> Gen.word Range.linearBounded , CAR <$> genAnnotation <*> genAnnotation , CDR <$> genAnnotation <*> genAnnotation - , LEFT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genValidType - , RIGHT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genValidType - , NIL <$> genAnnotation <*> genAnnotation <*> genValidType + , LEFT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genType + , RIGHT <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genType + , NIL <$> genAnnotation <*> genAnnotation <*> genType , CONS <$> genAnnotation , SIZE <$> genAnnotation - , EMPTY_SET <$> genAnnotation <*> genAnnotation <*> genValidType - , EMPTY_MAP <$> genAnnotation <*> genAnnotation <*> genValidType <*> genValidType - , EMPTY_BIG_MAP <$> genAnnotation <*> genAnnotation <*> genValidType <*> genValidType + , EMPTY_SET <$> genAnnotation <*> genAnnotation <*> genType + , EMPTY_MAP <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , EMPTY_BIG_MAP <$> genAnnotation <*> genAnnotation <*> genType <*> genType , MEM <$> genAnnotation , GET <$> genAnnotation , GETN <$> genAnnotation <*> Gen.word Range.linearBounded @@ -147,10 +149,10 @@ , EXEC <$> genAnnotation , APPLY <$> genAnnotation , pure FAILWITH - , CAST <$> genAnnotation <*> genValidType + , CAST <$> genAnnotation <*> genType , RENAME <$> genAnnotation , PACK <$> genAnnotation - , UNPACK <$> genAnnotation <*> genAnnotation <*> genValidType + , UNPACK <$> genAnnotation <*> genAnnotation <*> genType , CONCAT <$> genAnnotation , SLICE <$> genAnnotation , ISNAT <$> genAnnotation @@ -176,7 +178,7 @@ , GE <$> genAnnotation , INT <$> genAnnotation , SELF <$> genAnnotation <*> genAnnotation - , CONTRACT <$> genAnnotation <*> genAnnotation <*> genValidType + , CONTRACT <$> genAnnotation <*> genAnnotation <*> genType , TRANSFER_TOKENS <$> genAnnotation , SET_DELEGATE <$> genAnnotation , IMPLICIT_ACCOUNT <$> genAnnotation @@ -203,8 +205,8 @@ genContract' :: (MonadGen m, GenBase m ~ Identity) => m op -> m (Contract' op) genContract' genOp = Contract - <$> genParameterType True - <*> genValidType + <$> genParameterType + <*> genType <*> genSmallList genOp <*> genEntriesOrder <*> Gen.list (Range.exponential 0 2) (genSomeView genOp) @@ -220,19 +222,28 @@ genSomeView :: (MonadGen m, GenBase m ~ Identity) => m op -> m (View' op) genSomeView genOp = View <$> genViewName - <*> genValidType - <*> genValidType + <*> genType + <*> genType <*> genSmallList genOp genValue :: (MonadGen m, GenBase m ~ Identity) => m Value genValue = genValue' genExpandedOp +genValueInt :: MonadGen m => Range ValueInt -> m (Value' op) +genValueInt range = ValueInt <$> Gen.integral (unValueInt <$> range) + +genValueString :: MonadGen m => Range Length -> m (Value' op) +genValueString = fmap ValueString . genMText + +genValueBytes :: MonadGen m => Range Length -> m (Value' op) +genValueBytes = fmap ValueBytes . genInternalByteString + genValue' :: MonadGen m => m op -> m (Value' op) genValue' genOp = Gen.recursive Gen.choice -- non-recursive constructors - [ ValueInt <$> Gen.integral (Range.linearFrom 0 (fromIntegral $ minBound @Int64) (fromIntegral $ maxBound @Word64)) - , ValueString <$> genMText - , ValueBytes <$> genInternalByteString + [ genValueInt def + , genValueString def + , genValueBytes def , pure ValueUnit , pure ValueTrue , pure ValueFalse @@ -252,21 +263,12 @@ genElt :: MonadGen m => m op -> m (Elt op) genElt genOp = Elt <$> genValue' genOp <*> genValue' genOp -genParameterType :: - (MonadGen m, GenBase m ~ Identity) => Bool -> m ParameterType -genParameterType mustBeValid = - ParameterType <$> genType mustBeValid <*> genAnnotation - --- | Generate a 'Ty'. Note that 'Ty' may store invalid types by --- construction if you put a non-comparable type to a place where a --- comparable type is expected. The caller may request that generated --- value is guaranteed to be valid or can be invalid. -genType :: (MonadGen m, GenBase m ~ Identity) => Bool -> m Ty -genType mustBeValid = Ty <$> genT mustBeValid <*> genAnnotation +genParameterType :: (MonadGen m, GenBase m ~ Identity) => m ParameterType +genParameterType = ParameterType <$> genType <*> genAnnotation --- | Generate a 'Ty' that is guaranteed to be valid. -genValidType :: (MonadGen m, GenBase m ~ Identity) => m Ty -genValidType = genType True +-- | Generate a 'Ty'. +genType :: (MonadGen m, GenBase m ~ Identity) => m Ty +genType = Ty <$> genT <*> genAnnotation genComparableType :: (MonadGen m, GenBase m ~ Identity) => m Ty genComparableType = Ty <$> genComparableT <*> genAnnotation @@ -291,12 +293,9 @@ annBodyChar :: m Char annBodyChar = Gen.choice [ annStart, Gen.element (".%@" :: String) ] --- | Generate a 'T'. Note that 'T' may store invalid types by --- construction if you put a non-comparable type to a place where a --- comparable type is expected. The caller may request that generated --- value is guaranteed to be valid or can be invalid. -genT :: (MonadGen m, GenBase m ~ Identity) => Bool -> m T -genT mustBeValid = +-- | Generate a 'T'. +genT :: (MonadGen m, GenBase m ~ Identity) => m T +genT = Gen.recursive Gen.choice -- non-recursive constructors [ pure TKey @@ -317,18 +316,17 @@ , pure TChestKey ] -- recursive constructors - [ TOption <$> genType' - , TList <$> genType' + [ TOption <$> genType + , TList <$> genType , TSet <$> genComparableType - , TContract <$> genType' - , TPair <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genType' <*> genType' - , TOr <$> genAnnotation <*> genAnnotation <*> genType' <*> genType' - , TLambda <$> genType' <*> genType' - , TMap <$> genComparableType <*> genType' - , TBigMap <$> genComparableType <*> genType' + , TContract <$> genType + , TPair <$> genAnnotation <*> genAnnotation <*> genAnnotation + <*> genAnnotation <*> genType <*> genType + , TOr <$> genAnnotation <*> genAnnotation <*> genType <*> genType + , TLambda <$> genType <*> genType + , TMap <$> genComparableType <*> genType + , TBigMap <$> genComparableType <*> genType ] - where - genType' = genType mustBeValid -- We don't need to pass @mustBeValid@ here because comparable types are always valid. genComparableT :: (MonadGen m, GenBase m ~ Identity) => m T @@ -344,7 +342,8 @@ , pure TTimestamp , pure TAddress ] - [ TPair <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genComparableType <*> genComparableType + [ TPair <$> genAnnotation <*> genAnnotation <*> genAnnotation + <*> genAnnotation <*> genComparableType <*> genComparableType ] smallCollectionRange :: Range Int 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 @@ -3,41 +3,55 @@ module Hedgehog.Gen.Morley.Micheline ( genExpression + , genExpressionInt + , genExpressionString + , genExpressionBytes , genExpressionSeq + , genExpressionPrim , genMichelinePrimAp , genExprAnnotation ) where import Hedgehog (MonadGen(GenBase)) import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range +import Hedgehog.Range (Range) import Hedgehog.Gen.Michelson.Untyped (genAnnotation) import Morley.Micheline.Expression +import Hedgehog.Range.Defaults + genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression -genExpression = Gen.recursive Gen.choice - [genExpressionInt, genExpressionString, genExpressionBytes] - [genSeq, genExpressionPrim] - where - genExpressionInt = ExpressionInt <$> (Gen.integral (Range.linearFrom 0 -1000 1000)) - genExpressionString = ExpressionString <$> (Gen.text (Range.linear 0 10) Gen.unicodeAll) - genExpressionBytes = ExpressionBytes <$> (Gen.bytes (Range.linear 0 100)) - genSeq = ExpressionSeq <$> genExpressionSeq - genExpressionPrim = ExpressionPrim <$> genMichelinePrimAp +genExpression = Gen.recursive @m Gen.choice + [genExpressionInt def, genExpressionString def, genExpressionBytes def] + [genExpressionSeq def, genExpressionPrim] -genExpressionSeq :: forall m. (MonadGen m, GenBase m ~ Identity) => m [Expression] -genExpressionSeq = (Gen.list (Range.linear 0 10) genExpression) +genExpressionInt :: MonadGen f => Range ExpressionInt -> f Expression +genExpressionInt range = ExpressionInt <$> Gen.integral (unExpressionInt <$> range) -genMichelinePrimAp :: forall m. (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp -genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genExpressionSeq <*> genAnnots +genExpressionString :: MonadGen f => Range SmallLength -> f Expression +genExpressionString rangeLen = + ExpressionString <$> (Gen.text (unSmallLength <$> rangeLen) Gen.unicodeAll) + +genExpressionBytes :: MonadGen f => Range Length -> f Expression +genExpressionBytes rangeLen = ExpressionBytes <$> Gen.bytes (unLength <$> rangeLen) + +genExpressionSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m Expression +genExpressionSeq = fmap ExpressionSeq . genSeq + +genSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m [Expression] +genSeq rangeLen = Gen.list (unSmallLength <$> rangeLen) genExpression + +genExpressionPrim :: (MonadGen m, GenBase m ~ Identity) => m Expression +genExpressionPrim = ExpressionPrim <$> genMichelinePrimAp + +genMichelinePrimAp :: (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp +genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genSeq def <*> genAnnots where genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive) - - genAnnots :: m [Annotation] - genAnnots = Gen.list (Range.linear 0 10) genExprAnnotation + genAnnots = Gen.list (unSmallLength <$> def) genExprAnnotation -genExprAnnotation :: forall m. (MonadGen m, GenBase m ~ Identity) => m Annotation +genExprAnnotation :: (MonadGen m, GenBase m ~ Identity) => m Annotation genExprAnnotation = Gen.choice [genAnnotationType, genAnnotationVariable, genAnnotationField] where 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 @@ -4,68 +4,25 @@ module Hedgehog.Gen.Tezos.Core ( genChainId , genMutez - , genMutez' , genTimestamp - , minTimestamp - , maxTimestamp - , midTimestamp ) where -import Data.Time.Calendar (Day, addDays, diffDays) -import Data.Time.Clock (UTCTime(..)) -import Data.Time.Format (defaultTimeLocale, parseTimeM) import Hedgehog (MonadGen, Range) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Morley.Tezos.Core - (ChainId(..), Mutez(..), Timestamp, mkMutez, timestampFromSeconds, timestampFromUTCTime, - timestampToSeconds) + (ChainId(..), Mutez(..), Timestamp, mkMutez, timestampFromSeconds, timestampToSeconds) -import Test.Cleveland.Instances () +import Hedgehog.Range.Defaults () genChainId :: MonadGen m => m ChainId -genChainId = UnsafeChainId <$> Gen.bytes (Range.singleton 4) - --- | Generates an arbitrary `Mutez` value using the data type's full range. -genMutez :: MonadGen m => m Mutez -genMutez = genMutez' Range.linearBounded +genChainId = UnsafeChainId <$> Gen.bytes (Range.singleton 4) -- | Generates an arbitrary `Mutez` value constrained to the given range. -genMutez' :: MonadGen m => Range Mutez -> m Mutez -genMutez' range = unsafe . mkMutez <$> Gen.word64 (fromIntegral . unMutez <$> range) - -genTimestamp :: MonadGen m => m Timestamp -genTimestamp = - timestampFromSeconds <$> Gen.integral - (Range.linear (timestampToSeconds minTimestamp) (timestampToSeconds maxTimestamp)) - --- | Minimal (earliest) timestamp used for @Arbitrary (CValue 'CTimestamp)@ -minTimestamp :: Timestamp -minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromIntegralToRealFrac minSec) - --- | Maximal (latest) timestamp used for @Arbitrary (CValue 'CTimestamp)@ -maxTimestamp :: Timestamp -maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromIntegralToRealFrac maxSec) - --- | Median of 'minTimestamp' and 'maxTimestamp'. --- Useful for testing (exactly half of generated dates will be before and after --- this date). -midTimestamp :: Timestamp -midTimestamp = timestampFromUTCTime $ - UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay) - (fromIntegralToRealFrac $ (maxSec - minSec) `div` 2) - -minDay :: Day -minDay = fromMaybe (error "failed to parse day 2008-11-01") $ - parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01" - -maxDay :: Day -maxDay = fromMaybe (error "failed to parse day 2024-11-01") $ - parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01" - -minSec :: Integer -minSec = 0 +genMutez :: MonadGen m => Range Mutez -> m Mutez +genMutez range = unsafe . mkMutez <$> Gen.word64 (fromIntegral . unMutez <$> range) -maxSec :: Integer -maxSec = 86399 +genTimestamp :: MonadGen m => Range Timestamp -> m Timestamp +genTimestamp range = + timestampFromSeconds <$> Gen.integral (timestampToSeconds <$> range) diff --git a/src/Hedgehog/Range/Defaults.hs b/src/Hedgehog/Range/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Range/Defaults.hs @@ -0,0 +1,64 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Module declaring newtypes and 'Default' instances for 'Range'. +module Hedgehog.Range.Defaults + ( Default(..) + , Length(..) + , SmallLength(..) + , TinyLength(..) + , TicketAmount(..) + , ValueInt(..) + , ExpressionInt(..) + ) where + +import Data.Default (Default(..)) +import Hedgehog.Range (Range) +import Hedgehog.Range qualified as Range + +import Hedgehog.Range.Defaults.Orphans () + +-- | Newtype for specifying lengths of various containers. +newtype Length = Length { unLength :: Int } + deriving newtype (Eq, Ord, Integral, Enum, Bounded, Real, Num) + +instance Default (Range Length) where + def = Length <$> Range.linear 0 100 + +-- | Newtype for specifying lengths of various containers. +newtype SmallLength = SmallLength { unSmallLength :: Int } + deriving newtype (Eq, Ord, Integral, Enum, Bounded, Real, Num) + +instance Default (Range SmallLength) where + def = SmallLength <$> Range.linear 0 10 + +-- | Newtype for specifying lengths of various containers. +newtype TinyLength = TinyLength { unTinyLength :: Int } + deriving newtype (Eq, Ord, Integral, Enum, Bounded, Real, Num) + +instance Default (Range TinyLength) where + def = TinyLength <$> Range.linear 0 5 + +-- | Newtype for the range of @Ticket@ amount field. +newtype TicketAmount = MkTicketAmount { unTicketAmount :: Natural } + deriving newtype (Eq, Ord, Enum, Integral, Real, Num) + +instance Default (Range TicketAmount) where + def = MkTicketAmount <$> Range.linearFrom 0 0 1000 + +-- | Newtype for the range of @ValueInt@ constructor of untyped @Value'@. +newtype ValueInt = MkValueInt { unValueInt :: Integer } + deriving newtype (Eq, Ord, Enum, Integral, Real, Num) + +instance Default (Range ValueInt) where + def = MkValueInt <$> + Range.linearFrom 0 + (fromIntegral $ minBound @Int64) + (fromIntegral $ maxBound @Word64) + +-- | Newtype for the range of @ExpressionInt@ constructor of @Expression@. +newtype ExpressionInt = MkExpressionInt { unExpressionInt :: Integer } + deriving newtype (Eq, Ord, Enum, Integral, Real, Num) + +instance Default (Range ExpressionInt) where + def = MkExpressionInt <$> Range.linearFrom 0 -1000 1000 diff --git a/src/Hedgehog/Range/Defaults/Orphans.hs b/src/Hedgehog/Range/Defaults/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Range/Defaults/Orphans.hs @@ -0,0 +1,39 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | One place for orphan instances +module Hedgehog.Range.Defaults.Orphans + () where + +import Data.Default (Default(..)) +import Hedgehog.Range (Range) +import Hedgehog.Range qualified as Range + +import Morley.Michelson.ErrorPos (Pos(..)) +import Morley.Michelson.Typed (T(..), Value'(..)) +import Morley.Michelson.Untyped (StackRef(..)) +import Morley.Tezos.Core (Mutez(..), Timestamp, timestampFromSeconds, timestampToSeconds) + +import Hedgehog.Range.Tezos.Core.Timestamp +import Test.Cleveland.Instances () + +instance Default (Range Pos) where + def = Pos <$> Range.linearBounded + +instance Default (Range StackRef) where + def = StackRef <$> Range.linear 0 (fromIntegral $ maxBound @Word64) + +instance Default (Range Mutez) where + def = Range.linearBounded + +instance Default (Range Timestamp) where + def = timestampFromSeconds <$> + Range.linear (timestampToSeconds minTimestamp) (timestampToSeconds maxTimestamp) + +instance Default (Range (Value' instr 'TInt)) where + def = VInt <$> Range.linearFrom 0 -1000 1000 + +instance Default (Range (Value' instr 'TNat)) where + def = VNat <$> Range.linearFrom 0 0 1000 diff --git a/src/Hedgehog/Range/Tezos/Core/Timestamp.hs b/src/Hedgehog/Range/Tezos/Core/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Range/Tezos/Core/Timestamp.hs @@ -0,0 +1,53 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Timestamp range utility functions +module Hedgehog.Range.Tezos.Core.Timestamp + ( minTimestamp + , maxTimestamp + , midTimestamp + , timestampRangeFromSeconds + ) where + +import Data.Time.Calendar (Day, addDays, diffDays) +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Format (defaultTimeLocale, parseTimeM) +import Hedgehog.Range (Range) +import Hedgehog.Range qualified as Range + +import Morley.Tezos.Core (Timestamp, timestampFromSeconds, timestampFromUTCTime) + +-- | Generate a linear 'Range' of timestamps between lower and upper bounds specified in seconds +-- from the start of the UNIX epoch (Jan 1st 1970). +timestampRangeFromSeconds :: Integer -> Integer -> Range Timestamp +timestampRangeFromSeconds l h = timestampFromSeconds <$> Range.linear l h + +-- | Minimal (earliest) timestamp used for the default @Range Timestamp@ +minTimestamp :: Timestamp +minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromIntegralToRealFrac minSec) + +-- | Maximal (latest) timestamp used for the default @Range Timestamp@ +maxTimestamp :: Timestamp +maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromIntegralToRealFrac maxSec) + +-- | Median of 'minTimestamp' and 'maxTimestamp'. +-- Useful for testing (exactly half of generated dates will be before and after +-- this date). +midTimestamp :: Timestamp +midTimestamp = timestampFromUTCTime $ + UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay) + (fromIntegralToRealFrac $ (maxSec - minSec) `div` 2) + +minDay :: Day +minDay = fromMaybe (error "failed to parse day 2008-11-01") $ + parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01" + +maxDay :: Day +maxDay = fromMaybe (error "failed to parse day 2024-11-01") $ + parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01" + +minSec :: Integer +minSec = 0 + +maxSec :: Integer +maxSec = 86399 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 @@ -30,7 +30,6 @@ import Test.HUnit.Lang (HUnitFailure(..)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import Text.Show qualified import Morley.Michelson.Doc @@ -63,9 +62,6 @@ instance Eq DocTest where (==) = (==) `on` dtDeclLoc - -instance Show DocTest where - show = pretty instance Buildable DocTest where build DocTest{..} = "Doc test '" <> build dtDesc <> "'" 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 @@ -110,7 +110,7 @@ import Lorentz (Contract(..)) import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC) -import Morley.Client (Alias, AliasHint, Result) +import Morley.Client (AliasHint, Result) import Morley.Client.Types import Morley.Micheline (Expression, fromExpression) import Morley.Michelson.ErrorPos (InstrCallStack) @@ -249,7 +249,7 @@ data ClevelandMiscImpl m = ClevelandMiscImpl { cmiRunIO :: forall res. HasCallStack => IO res -> m res -- ^ Runs an 'IO' action. - , cmiResolveAddress :: HasCallStack => Alias -> m Address + , cmiResolveAddress :: HasCallStack => AliasHint -> m Address -- ^ Get the address of the implicit account / contract associated with the given alias. , cmiGenKey :: HasCallStack => SpecificOrDefaultAliasHint -> m Address -- ^ Generate a secret key and store it with given alias. 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 @@ -121,7 +121,7 @@ import Lorentz.Bytes import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(..)) -import Morley.Client (Alias, OperationInfo(..)) +import Morley.Client (OperationInfo(..)) import Morley.Micheline (Expression, FromExpression(..), toExpression) import Morley.Michelson.Printer.Util (buildRenderDoc) import Morley.Michelson.Runtime (VotingPowers) @@ -195,8 +195,10 @@ runIO io = do withCap getMiscCap \cap -> cmiRunIO cap io --- | Get the address of the implicit account / contract associated with the given alias. -resolveAddress :: (HasCallStack, MonadCleveland caps m) => Alias -> m Address +-- | Get the address of the implicit account / contract associated with the given alias hint. +resolveAddress + :: (HasCallStack, MonadCleveland caps m) + => AliasHint -> m Address resolveAddress alias = do withCap getMiscCap \cap -> cmiResolveAddress cap alias 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 @@ -61,6 +61,7 @@ (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp), BlockId(..), OperationHash, OriginationScript(..), ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize)) +import Morley.Client.TezosClient.Impl qualified as Client (prefixNameM) import Morley.Client.Util qualified as Client import Morley.Micheline (Expression, FromExpression(fromExpression), MichelinePrimitive(..), StringEncode(..), TezosInt64, @@ -299,8 +300,10 @@ , indentF 2 $ build err ] - cmiResolveAddress :: Alias -> ClientM Address - cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias + cmiResolveAddress :: Client.AliasHint -> ClientM Address + cmiResolveAddress = liftIO . runMorleyClientM env . + (Client.resolveAddress . AddressAlias <=< Client.prefixNameM) . + Client.AnAliasHint cmiGetPublicKey :: Address -> ClientM PublicKey cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved 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 @@ -516,8 +516,8 @@ "Expected address to be contract with storage, but it's a simple address: " <> pretty addr Nothing -> unknownAddress addr -resolve :: Alias -> PureM Address -resolve name = do +resolve :: AliasHint -> PureM Address +resolve (hintToAlias -> name) = do aliases <- use psAliases let maybeAddress = Map.lookup name aliases maybe (unknownAlias name) (pure . adAddress) maybeAddress 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 @@ -147,7 +147,7 @@ -- | A global mutex to ensure only one cleveland test is executed at a time. -- --- TODO: Remove this when #399 is done. +-- TODO [#399]: Remove this when is done. -- https://gitlab.com/morley-framework/morley/-/issues/399 -- -- See also: https://wiki.haskell.org/Top_level_mutable_state 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 @@ -304,13 +304,17 @@ formatSomeValue (SomeConstrainedValue v) = formatValue v -- | Derive a 'Show' instance for a type using a custom "show" function. +-- Note: the `show`n value is paren-wrapped iff it's a subexpression, +-- just as an ordinary `Show` would do. data ShowWith a = ShowWith (a -> String) a instance Eq a => Eq (ShowWith a) where ShowWith _ x == ShowWith _ y = x == y instance Show (ShowWith a) where - show (ShowWith f a) = f a + showsPrec d (ShowWith f a) = Text.Show.showParen (d > app_prec) $ Text.Show.showString $ f a + where + app_prec = 10 -- | Derive a 'Buildable' instance for a type using 'show'. newtype Showing a = Showing a diff --git a/test-common/Test/Util/Contracts.hs b/test-common/Test/Util/Contracts.hs deleted file mode 100644 --- a/test-common/Test/Util/Contracts.hs +++ /dev/null @@ -1,106 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Utility functions to read sample contracts (for testing). - -module Test.Util.Contracts - ( contractsDir - , inContractsDir - , () - - , getIllTypedContracts - , getWellTypedContracts - , getUnparsableContracts - , getWellTypedMichelsonContracts - , getWellTypedMorleyContracts - , getContractsWithReferences - ) where - -import Data.List (isSuffixOf) -import System.Directory (listDirectory) -import System.FilePath (addExtension, ()) - --- | Directory with sample contracts. -contractsDir :: FilePath -contractsDir = "../../contracts/" - -inContractsDir :: FilePath -> FilePath -inContractsDir = (contractsDir ) - -getIllTypedContracts :: IO [FilePath] -getIllTypedContracts = do - illTyped <- concatMapM (\ext -> - concatMapM (getContractsWithExtension ext) - illTypedContractDirs - ) [".tz", ".mtz"] - unparsable <- getUnparsableContracts - return $ filter (not . (flip elem unparsable)) illTyped - -getWellTypedContracts :: IO [FilePath] -getWellTypedContracts = getWellTypedMichelsonContracts <> getWellTypedMorleyContracts - -getUnparsableContracts :: IO [FilePath] -getUnparsableContracts = do - unparsable <- concatMapM (flip getContractsWithExtension (contractsDir "unparsable")) - [".tz", ".mtz"] - return $ unparsable ++ unparsableExample - - -getWellTypedMichelsonContracts :: IO [FilePath] -getWellTypedMichelsonContracts = - concatMapM (getContractsWithExtension ".tz") wellTypedContractDirs - -getWellTypedMorleyContracts :: IO [FilePath] -getWellTypedMorleyContracts = concatMapM (getContractsWithExtension ".mtz") wellTypedContractDirs - -getContractsWithExtension :: String -> FilePath -> IO [FilePath] -getContractsWithExtension ext dir = mapMaybe convertPath <$> listDirectory dir - where - convertPath :: FilePath -> Maybe FilePath - convertPath fileName - | (ext `isSuffixOf` fileName) = - Just (dir fileName) - | otherwise = Nothing - -wellTypedContractDirs :: [FilePath] -wellTypedContractDirs = - contractsDir : - map ((contractsDir "tezos_examples") ) - [ "attic" - , "entrypoints" - , "macros" - , "mini_scenarios" - , "non_regression" - , "opcodes" - ] - -illTypedContractDirs :: [FilePath] -illTypedContractDirs = - [ contractsDir "ill-typed" - , contractsDir "tezos_examples" "ill_typed" - , contractsDir "tezos_examples" "legacy" - ] - -unparsableExample :: [FilePath] -unparsableExample = - [ contractsDir "tezos_examples" "ill_typed" name - | name <- - [ "big_map_arity.tz" - , "view_op_invalid_arity.tz" - , "view_toplevel_invalid_arity.tz" - ] - ++ - [ "view_" <> kind <> "_bad_name_" <> name <> ".tz" - | kind <- [ "op", "toplevel" ] - , name <- [ "invalid_type", "invalid_char_set", "non_printable_char" - , "too_long" - ] - ] - ] - -getContractsWithReferences :: String -> FilePath -> String -> IO [(FilePath, FilePath)] -getContractsWithReferences ext fp refExt = - fmap attachPrettyPath <$> getContractsWithExtension ext fp - where - attachPrettyPath :: FilePath -> (FilePath, FilePath) - attachPrettyPath src = (src, addExtension src refExt) 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 @@ -27,10 +27,10 @@ import Test.Tasty.Runners (Result(resultDescription)) import Time (sec) -import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL, mkAlias) +import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL) import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue) -import Morley.Tezos.Address (parseAddress) +import Morley.Tezos.Address (ta) import Morley.Util.Interpolate (lit) import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL) @@ -680,8 +680,8 @@ ] where - invalidAlias = mkAlias "UnknownAlias" - invalidAddr = unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC" + invalidAlias = "UnknownAlias" + invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] invalidTAddr = TAddress @() invalidAddr test_callStack_property :: TestTree 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 @@ -12,7 +12,7 @@ import Morley.Michelson.Typed qualified as T import Morley.Tezos.Core (Mutez) import Test.Cleveland -import Test.Util.Contracts (inContractsDir) +import TestSuite.Util.Contracts (inContractsDir) data TransferAllParameter = ReceiveXtz 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 @@ -10,8 +10,8 @@ import Morley.Tezos.Address (Address) import Test.Cleveland -import Test.Util.Contracts import TestSuite.Util (idContract, shouldFailWithMessage) +import TestSuite.Util.Contracts test_replayTransfer_fails :: TestTree test_replayTransfer_fails = 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 @@ -3,6 +3,7 @@ module TestSuite.Cleveland.PrefixNetworkScenario ( test_PrefixNetworkScenario + , test_newAddress_with_prefix ) where import Data.Fixed (Nano) @@ -12,29 +13,29 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@=?)) -import Morley.Client as Client +import Morley.Client qualified as Client import Morley.Client.TezosClient.Types (tceAliasPrefixL, tceMbTezosClientDataDirL) import Morley.Tezos.Crypto (SecretKey, detSecretKey) import Test.Cleveland import Test.Cleveland.Internal.Abstract (Moneybag(Moneybag), moneybagL) import Test.Cleveland.Internal.Client (neMoneybagAliasL, neMorleyClientEnvL, neSecretKeyL, runClevelandT) -import Test.Cleveland.Tasty (modifyNetworkEnv, whenNetworkEnabled) +import Test.Cleveland.Tasty (modifyNetworkEnv, setAliasPrefix, whenNetworkEnabled) -aliasName :: Alias -aliasName = mkAlias "testMoneybagAlias" +aliasName :: Client.Alias +aliasName = Client.mkAlias "testMoneybagAlias" aliasPrefix :: Text aliasPrefix = "testPrefix" mangleNetworkEnv :: SecretKey -> TestTree -> TestTree mangleNetworkEnv sk = modifyNetworkEnv $ - (neMorleyClientEnvL . mceTezosClientL . tceAliasPrefixL .~ Just aliasPrefix) + (neMorleyClientEnvL . Client.mceTezosClientL . tceAliasPrefixL .~ Just aliasPrefix) . (neSecretKeyL .~ Just sk) . (neMoneybagAliasL .~ aliasName) setTmpDir :: FilePath -> NetworkEnv -> NetworkEnv -setTmpDir dir = neMorleyClientEnvL . mceTezosClientL . tceMbTezosClientDataDirL .~ Just dir +setTmpDir dir = neMorleyClientEnvL . Client.mceTezosClientL . tceMbTezosClientDataDirL .~ Just dir test_PrefixNetworkScenario :: IO TestTree test_PrefixNetworkScenario = do @@ -52,6 +53,15 @@ let env = setTmpDir tmpdir env' Moneybag moneybagAddress <- runClevelandT env $ view moneybagL - actualAlias <- runMorleyClientM (neMorleyClientEnv env) $ - Client.getAlias $ AddressResolved moneybagAddress + actualAlias <- Client.runMorleyClientM (neMorleyClientEnv env) $ + Client.getAlias $ Client.AddressResolved moneybagAddress actualAlias @=? aliasName + +test_newAddress_with_prefix :: TestTree +test_newAddress_with_prefix = + setAliasPrefix "prefix" $ + testScenario "`newAddress` prepends alias prefix to alias hint" $ scenario do + addr1 <- newAddress "alias" + addr2 <- resolveAddress "alias" + + addr1 @== addr2 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 @@ -15,8 +15,8 @@ import Morley.Util.SizedList.Types import Test.Cleveland -import Test.Util.Contracts import TestSuite.Util (shouldFailWithMessage) +import TestSuite.Util.Contracts test_AddressRefills :: [TestTree] test_AddressRefills = 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 @@ -23,8 +23,8 @@ import Test.Cleveland import Test.Cleveland.Lorentz (embedContract) -import Test.Util.Contracts (contractsDir) import TestSuite.Util (BigMapInStorage(..), idContract, saveInStorageContract) +import TestSuite.Util.Contracts (contractsDir) data Storage = Storage { _stField1 :: Natural diff --git a/test/TestSuite/Util/Contracts.hs b/test/TestSuite/Util/Contracts.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Util/Contracts.hs @@ -0,0 +1,19 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Utility functions to read sample contracts (for testing). + +module TestSuite.Util.Contracts + ( contractsDir + , inContractsDir + , () + ) where + +import System.FilePath (()) + +-- | Directory with sample contracts. +contractsDir :: FilePath +contractsDir = "../../contracts/" + +inContractsDir :: FilePath -> FilePath +inContractsDir = (contractsDir )