packages feed

cleveland (empty) → 0.1.0

raw patch · 203 files changed

+29274/−0 lines, 203 filesdep +HUnitdep +MonadRandomdep +aeson

Dependencies added: HUnit, MonadRandom, aeson, aeson-pretty, aeson-qq, base-noprelude, bimap, bytestring, cleveland, constraints, containers, criterion, cryptonite, data-default, directory, either, exceptions, file-embed, filepath, first-class-families, fmt, gauge, hedgehog, hex-text, hspec, hspec-expectations, lens, lorentz, megaparsec, morley, morley-client, morley-prelude, mtl, named, o-clock, optparse-applicative, safe-exceptions, servant-client, servant-client-core, silently, singletons, spoon, statistics, syb, tagged, tasty, tasty-ant-xml, tasty-hedgehog, tasty-hspec, tasty-hunit-compat, template-haskell, text, time, type-spec, unordered-containers, vinyl, with-utf8

Files

+ CHANGES.md view
@@ -0,0 +1,8 @@+<!-- Unreleased: append new entries here -->+++0.1.0+=====+Initial release extracted from the [morley](https://hackage.haskell.org/package/morley)+and [lorentz](https://hackage.haskell.org/package/lorentz) packages.+Tezos testing framework for contract developed with Michelson, Morley or Lorentz.
+ LICENSE view
@@ -0,0 +1,19 @@+MIT License Copyright (c) 2020 Tocqueville Group++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+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 (including the next+paragraph) 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.
+ README.md view
@@ -0,0 +1,14 @@+# Cleveland: A testing framework for Morley++This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz.++These tests can be run using the `Test.Cleveland` module:+* on an emulated environment+* on a real network (e.g. testnet).+  In addition to a testnet, one can also use a [local-chain](https://gitlab.com/morley-framework/local-chain)+  with short block periods in order to speed up testing process.++This interface is documented in detail [here](https://gitlab.com/morley-framework/morley/-/blob/master/code/cleveland/testingEDSL.md).++We also provide several Hedgehog generators for most of `morley`'s data types+in the `Hedgehog.Gen.*` modules.
+ cleveland.cabal view
@@ -0,0 +1,729 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           cleveland+version:        0.1.0+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+homepage:       https://gitlab.com/morley-framework/morley+bug-reports:    https://gitlab.com/morley-framework/morley/-/issues+author:         Serokell, Tocqueville Group+maintainer:     Serokell <hi@serokell.io>+copyright:      2020 Tocqueville Group+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    test/fixtures/addrValue.txt+    test/fixtures/addrValue.txt.license+    test/fixtures/intValue.txt+    test/fixtures/intValue.txt.license+extra-doc-files:+    README.md+    CHANGES.md++source-repository head+  type: git+  location: git@gitlab.com:morley-framework/morley.git++library+  exposed-modules:+      Hedgehog.Gen.Michelson+      Hedgehog.Gen.Michelson.Typed+      Hedgehog.Gen.Michelson.Untyped+      Hedgehog.Gen.Morley.Micheline+      Hedgehog.Gen.Tezos.Address+      Hedgehog.Gen.Tezos.Core+      Hedgehog.Gen.Tezos.Crypto+      Hedgehog.Gen.Tezos.Crypto.BLS12381+      Hedgehog.Gen.Tezos.Crypto.Ed25519+      Hedgehog.Gen.Tezos.Crypto.P256+      Hedgehog.Gen.Tezos.Crypto.Secp256k1+      Hedgehog.Gen.Tezos.Crypto.Timelock+      Test.Cleveland+      Test.Cleveland.Doc+      Test.Cleveland.Doc.Common+      Test.Cleveland.Doc.Lorentz+      Test.Cleveland.Doc.Michelson+      Test.Cleveland.Ingredients+      Test.Cleveland.Instances+      Test.Cleveland.Internal.Abstract+      Test.Cleveland.Internal.Actions+      Test.Cleveland.Internal.Client+      Test.Cleveland.Internal.Exceptions+      Test.Cleveland.Internal.Hedgehog+      Test.Cleveland.Internal.Pure+      Test.Cleveland.Internal.Scenario+      Test.Cleveland.Lorentz+      Test.Cleveland.Lorentz.Consumer+      Test.Cleveland.Lorentz.Entrypoints+      Test.Cleveland.Lorentz.Import+      Test.Cleveland.Lorentz.Internal.Entrypoints+      Test.Cleveland.Lorentz.Requester+      Test.Cleveland.Lorentz.Ticketer+      Test.Cleveland.Lorentz.Types+      Test.Cleveland.Michelson+      Test.Cleveland.Michelson.Dummy+      Test.Cleveland.Michelson.Entrypoints+      Test.Cleveland.Michelson.Import+      Test.Cleveland.Michelson.Internal.Entrypoints+      Test.Cleveland.Michelson.Unit+      Test.Cleveland.Tasty+      Test.Cleveland.Tasty.Internal+      Test.Cleveland.Tasty.Internal.Options+      Test.Cleveland.Tasty.Internal.Report+      Test.Cleveland.Util+  other-modules:+      Paths_cleveland+  autogen-modules:+      Paths_cleveland+  hs-source-dirs:+      src+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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:+      HUnit+    , MonadRandom+    , aeson+    , base-noprelude >=4.7 && <5+    , constraints >=0.11+    , containers+    , criterion+    , cryptonite+    , data-default+    , directory+    , either+    , exceptions+    , file-embed+    , fmt+    , hedgehog >=1.0.3+    , hex-text+    , hspec+    , hspec-expectations+    , lens+    , lorentz+    , morley+    , morley-client+    , morley-prelude+    , mtl+    , named+    , o-clock+    , optparse-applicative+    , safe-exceptions+    , servant-client-core+    , singletons+    , statistics+    , tagged+    , tasty >=1.4+    , tasty-ant-xml+    , tasty-hedgehog+    , tasty-hunit-compat+    , template-haskell+    , text+    , time+    , with-utf8+  default-language: Haskell2010++test-suite cleveland-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      TestSuite.Cleveland.AddressRevealing+      TestSuite.Cleveland.Assertions+      TestSuite.Cleveland.BalanceCheck+      TestSuite.Cleveland.BatchOperation+      TestSuite.Cleveland.BatchTransferCheck+      TestSuite.Cleveland.BlockIntervalGetter+      TestSuite.Cleveland.BytesSigning+      TestSuite.Cleveland.CallStack+      TestSuite.Cleveland.ChainIdGet+      TestSuite.Cleveland.ContractAllocation+      TestSuite.Cleveland.DFS+      TestSuite.Cleveland.Emulated+      TestSuite.Cleveland.Entrypoints+      TestSuite.Cleveland.ExpectFailure+      TestSuite.Cleveland.FailureLogs+      TestSuite.Cleveland.Import+      TestSuite.Cleveland.InitialState+      TestSuite.Cleveland.Level+      TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator+      TestSuite.Cleveland.Lorentz.Entrypoints+      TestSuite.Cleveland.NewAddressCheck+      TestSuite.Cleveland.OperationReplay+      TestSuite.Cleveland.PrefixNetworkScenario+      TestSuite.Cleveland.PrettyFailWith+      TestSuite.Cleveland.PublicKeyToAddress+      TestSuite.Cleveland.RefillableAddress+      TestSuite.Cleveland.StorageCheck+      TestSuite.Cleveland.StorageWithBigMaps+      TestSuite.Cleveland.Tasty+      TestSuite.Cleveland.Tasty.Report+      TestSuite.Cleveland.Tasty.Report.Examples+      TestSuite.Cleveland.Time+      TestSuite.Cleveland.TransferCheck+      TestSuite.Cleveland.UsedFramework+      TestSuite.Cleveland.Util+      TestSuite.Cleveland.VotingPower+      TestSuite.Cleveland.WithMoneybag+      TestSuite.Cleveland.WithSender+      TestSuite.Util+      Tree+      Test.Util.Contracts+      Paths_cleveland+  hs-source-dirs:+      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+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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:+      base-noprelude >=4.7 && <5+    , cleveland+    , directory+    , either+    , filepath+    , fmt+    , hedgehog >=1.0.3+    , hspec-expectations+    , lens+    , lorentz+    , morley+    , morley-client+    , morley-prelude+    , named+    , o-clock+    , servant-client+    , tasty+    , tasty-hedgehog+    , tasty-hunit-compat+    , 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.Entrypoints+      Test.Lorentz.Entrypoints.Doc+      Test.Lorentz.Errors+      Test.Lorentz.Errors.Numeric+      Test.Lorentz.Expr+      Test.Lorentz.Extensible+      Test.Lorentz.Interpreter+      Test.Lorentz.Macro+      Test.Lorentz.MorleyLogs+      Test.Lorentz.Optimizer+      Test.Lorentz.Pack+      Test.Lorentz.Print+      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+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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+      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+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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:+      base-noprelude >=4.7 && <5+    , cleveland+    , 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.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.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.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+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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+    , 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+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      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
+ lorentz-test/Main.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Cleveland.Ingredients (ourIngredients)+import Test.Cleveland.Tasty (clevelandMainWithIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= clevelandMainWithIngredients ourIngredients
+ lorentz-test/Test/Doc.hs view
@@ -0,0 +1,161 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on automatic documentation generation.++module Test.Doc+  ( test_General_doc_scan+  , test_Dependencies_loops+  , test_Cutting_all_except_doc+  , test_fakeCoerce+  ) where++import qualified Data.Set as Set+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 qualified Lorentz as L+import Morley.Michelson.Doc+import Morley.Michelson.Typed+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 $ "Unexpected subcontents: " <> show subcontents+            _ -> assertFailure $ "Unexpected contents: " <> show 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+  ]
+ lorentz-test/Test/DocTest.hs view
@@ -0,0 +1,71 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Lorentz 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+      ]+  ]
+ lorentz-test/Test/Lorentz/BLS12381.hs view
@@ -0,0 +1,29 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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 qualified Morley.Tezos.Crypto.BLS12381 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
+ lorentz-test/Test/Lorentz/Base.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)
+ lorentz-test/Test/Lorentz/Case.hs view
@@ -0,0 +1,66 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Lorentz 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]+  ]
+ lorentz-test/Test/Lorentz/Conditionals.hs view
@@ -0,0 +1,65 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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
+ lorentz-test/Test/Lorentz/ContractRegistry.hs view
@@ -0,0 +1,69 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- {-# 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 qualified Data.Map 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 " <> show 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 ()
+ lorentz-test/Test/Lorentz/CustomArith.hs view
@@ -0,0 +1,325 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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+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))
+ lorentz-test/Test/Lorentz/CustomValue.hs view
@@ -0,0 +1,261 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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.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)++----------------------------------------------------------------------------+-- 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 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
+ lorentz-test/Test/Lorentz/DeadCode.hs view
@@ -0,0 +1,62 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- 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 qualified Lorentz as L+import Lorentz.Base+import Lorentz.Run+import Morley.Michelson.Typed (Instr(Seq))+import qualified Morley.Michelson.Typed 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
+ lorentz-test/Test/Lorentz/Doc/Positions.hs view
@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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+  ]
+ lorentz-test/Test/Lorentz/Entrypoints.hs view
@@ -0,0 +1,527 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Lorentz 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, HasAnnotation)++data MyEntrypoints1a+  = Do1a Integer+  | Do2a (Integer, Integer)+  | Do3a MyEntrypoints2+  | Do4a MyParams+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++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, HasAnnotation)++data MyEntrypoints4+  = Do14 ("viewarg1" :! L.View_ ("owner" :! L.Address) Natural)+  | Do15 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints5+  = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural))+  | Do17 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints6+  = Do18 ("lambdaarg" :! L.Lambda Natural Natural)+  | Do19 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints7+  = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)])+  | Do21 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints8+  = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address)))+  | Do23 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints9+  = Do24 ("maybearg" :? ("maybeinner" :! Natural))+  | Do25 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints10+  = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ())+  | Do27 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++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, HasAnnotation)++data MyEntrypointsWithRoot+  = Dor1+  | Dor2 Natural+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypointsWithCustomAnn+  = Doc1 Natural+  | Doc2 CustomProd+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++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, HasAnnotation)++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 arg = L.defaultContract $+  L.car # L.contractCalling epRef #+  L.assertSome ("Contract lookup failed" :: MText) #+  L.push 1 # L.push arg # 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+  ]
+ lorentz-test/Test/Lorentz/Entrypoints/Doc.hs view
@@ -0,0 +1,235 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Lorentz 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, HasAnnotation)++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, HasAnnotation)++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, HasAnnotation)++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, HasAnnotation)++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, HasAnnotation)++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
+ lorentz-test/Test/Lorentz/Errors.hs view
@@ -0,0 +1,122 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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 qualified Data.Bimap as Bimap+import qualified Data.HashSet 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
+ lorentz-test/Test/Lorentz/Errors/Numeric.hs view
@@ -0,0 +1,71 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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 qualified Lorentz 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"+  ]
+ lorentz-test/Test/Lorentz/Expr.hs view
@@ -0,0 +1,46 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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+  ]
+ lorentz-test/Test/Lorentz/Extensible.hs view
@@ -0,0 +1,67 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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
+ lorentz-test/Test/Lorentz/Interpreter.hs view
@@ -0,0 +1,153 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.Interpreter+  ( test_Entry_points_lookup+  , test_Entry_points_calling+  ) where++import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)++import Lorentz (EpdPlain, HasAnnotation, ParameterHasEntrypoints(..), toAddress)+import Morley.Michelson.Text+import Morley.Michelson.Typed (IsoValue(..))+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Test.Cleveland+import Test.Cleveland.Michelson (testTreesWithTypedContract)++data Contract1Parameter+  = Contract11 Integer+  | Contract12 MText+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data Self1Parameter+  = Self11 Integer+  | Self12 ()+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++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 <- importContract @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 <- importContract @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"
+ lorentz-test/Test/Lorentz/Macro.hs view
@@ -0,0 +1,91 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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_duupX+  , unit_replaceN+  , unit_updateN+  , test_execute+  , test_applicate+  ) where++import Lorentz+import Prelude hiding (drop, swap)++import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+++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_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++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+  ]
+ lorentz-test/Test/Lorentz/MorleyLogs.hs view
@@ -0,0 +1,116 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)++test_MorleyLogs :: IO [TestTree]+test_MorleyLogs =+  testTreesWithUntypedContract "../../contracts/empties.tz" $ \withoutLogs ->+  testTreesWithUntypedContract "../../contracts/single_log.mtz" $ \withSingleLog ->+  testTreesWithUntypedContract "../../contracts/multiple_logs.mtz" $ \withMultiLogs ->+  pure+  [ testGroup "Checking MorleyLogs processing"+    [ testScenarioOnEmulator "Calling contract with single log" $ scenarioEmulated do+        idAddr <- originateS withSingleLog+        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 withSingleLog+        idAddrM <- originateM withMultiLogs+        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 withSingleLog+        idAddrM <- originateM withMultiLogs+        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 withSingleLog+            logsInfo <- getMorleyLogs_ $+              call idAddr CallDefault ()+            logsForAddress idAddr logsInfo @== fmap MorleyLogs [["log"]])++          , ("2", do+            idAddr <- originateS withSingleLog+            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, originateS, originateM+      :: forall caps m. MonadCleveland caps m+      => Morley.Michelson.Untyped.Contract+      -> m (TAddress () ())+    originateW = originateContract "without logs"+    originateS = originateContract "with single log"+    originateM = originateContract "with multiple logs"++    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
+ lorentz-test/Test/Lorentz/Optimizer.hs view
@@ -0,0 +1,48 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for optimization of Lorentz-specific instruction sequences.+module Test.Lorentz.Optimizer+  ( unit_eq0+  , unit_non+  , unit_stGet+  ) where++import Lorentz ((#), (:->))+import qualified Lorentz 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
+ lorentz-test/Test/Lorentz/Pack.hs view
@@ -0,0 +1,48 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for Lorentz packing/unpacking++module Test.Lorentz.Pack+  ( test_lambda_roundtrip+  ) where++import Lorentz+import Prelude hiding (drop, swap)++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: " <> show err+  Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of+    [] -> ul @?= l+    notes -> assertFailure $ "Lambda has annotations: " <> show notes+  where+    dfsSettings :: DfsSettings [Text]+    dfsSettings = def { dsGoToValues = True}++    instrNotes :: Instr inp out -> [Text]+    instrNotes = \case+      InstrWithNotes _ n _ -> [show n]+      _ -> []
+ lorentz-test/Test/Lorentz/Print.hs view
@@ -0,0 +1,79 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on Lorentz contracts pretty-printing.+module Test.Lorentz.Print+  ( test_Print_parameter_annotations+  , test_Print_lambda+  , unit_Erase_annotations+  ) where++import Lorentz hiding (contract, unpack)+import qualified Lorentz 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" :! Bool)+  | TestCon2 ()+  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 () ()+    myContract = defaultContract $+      cdr # nil # L.pair++    expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };"+  in assertEqual+      "Printed Lorentz contract is supposed to have an instruction which erases\+      \all parameter annotations, but it does not match the expected output"+      expected (L.printLorentzContract True myContract)
+ lorentz-test/Test/Lorentz/ReferencedByName.hs view
@@ -0,0 +1,35 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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+  ]
+ lorentz-test/Test/Lorentz/Storage.hs view
@@ -0,0 +1,196 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Lorentz 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.NiceStorage 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.NiceStorage 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.NiceStorage st => TypeAnnTree (ToT st)+    extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st)
+ lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs view
@@ -0,0 +1,112 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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.Annotation (HasAnnotation)+import Lorentz.Run.Simple+import Lorentz.StoreClass+import qualified Lorentz.StoreClass.Extra 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, HasAnnotation)++data SubStorage = SubStorage+  { ssField1 :: Group+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (IsoValue, HasAnnotation)++data Group = Group+  { gField :: Integer+  , gSubmap :: Map MText Natural+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (IsoValue, HasAnnotation)++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+  ]
+ lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs view
@@ -0,0 +1,143 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.StoreClass.SetSubmap+  ( test_Simple_set+  ) where++import Prelude hiding (drop, swap)++import qualified Data.Set as S+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++import qualified Lorentz as L+import Lorentz.Annotation (HasAnnotation)+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, HasAnnotation)++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]++    ]++  ]
+ lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs view
@@ -0,0 +1,159 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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, HasAnnotation)++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
+ lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs view
@@ -0,0 +1,292 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 qualified Data.Map as M+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++import qualified Lorentz as L+import Lorentz.Annotation (HasAnnotation)+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, HasAnnotation)++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)]))]+      ]++    ]+  ]
+ lorentz-test/Test/Lorentz/Tickets.hs view
@@ -0,0 +1,92 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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++    ]++  ]
+ lorentz-test/Test/Lorentz/Tickets/Contracts.hs view
@@ -0,0 +1,164 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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, HasAnnotation)++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
+ lorentz-test/Test/Lorentz/Tickets/Helpers.hs view
@@ -0,0 +1,168 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on tickets helpers from "Lorentz.Tickets" module.+module Test.Lorentz.Tickets.Helpers+  ( test_ActionAuth+  , test_TokenAllowance+  ) where++import Test.Tasty (TestTree, testGroup)++import qualified Lorentz 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
+ lorentz-test/Test/Lorentz/Timelock.hs view
@@ -0,0 +1,81 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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+  ]
+ lorentz-test/Test/Lorentz/UParam.hs view
@@ -0,0 +1,95 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for Lorentz 'UParam'.+module Test.Lorentz.UParam+  ( test_Simple_contract+  , test_ADT_conversion+  , unit_unpackUParam+  ) where++import Data.Constraint (Dict(..))+import Test.HUnit (Assertion, assertBool, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz ((/->))+import qualified Lorentz 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 show) . unpackUParam @Show++-- 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 ()))+  ]
+ lorentz-test/Test/Lorentz/Views.hs view
@@ -0,0 +1,188 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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++  ]
+ lorentz-test/Test/Lorentz/ViewsImport.hs view
@@ -0,0 +1,96 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Util.Contracts++import qualified Morley.Michelson.Typed 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 T.TNat T.TInt++  , testCase "One view with wrong ret type" do+      importContract' @WrongIdView2+        `catch` \e ->+          e @?= VIMViewRetMismatch (T.TPair T.TNat T.TUnit) (T.TPair T.TInt T.TUnit)++  , 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 T.TNever T.TUnit+  ]
+ lorentz-test/Test/Tasty/TypeSpec.hs view
@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)++instance IsTest TypeTestCase where+  -- Implementation here is similar to the one from HUnit integration+  run _ (TypeTestCase spec) _ =+    -- According to documentation of TypeSpec, the only sensible thing we can+    -- do with spec value is to print it.+    -- TypeSpec test suites are ensured at compile time.+    return . testPassed $ show spec++  testOptions = pure []++-- | Turn a 'TypeSpec' into tasty test case.+typeTest+  :: PrettyTypeSpec expectation+  => TestName -> TypeSpec expectation -> TestTree+typeTest name spec = singleTest name (TypeTestCase spec)
+ lorentz-test/Test/Util/Annotation.hs view
@@ -0,0 +1,83 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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
+ lorentz-test/Test/Util/TypeSpec.hs view
@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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++-- | 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"
+ lorentz-test/Tree.hs view
@@ -0,0 +1,5 @@+-- 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 #-}
+ morley-bench/Main.hs view
@@ -0,0 +1,75 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main (main) where++import Data.Default (def)+import qualified Data.Text.IO.Utf8 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 = unsafeMkMText "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]+    ]
+ morley-client-test/Main.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Cleveland.Ingredients (ourIngredients)+import Test.Cleveland.Tasty (clevelandMainWithIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= clevelandMainWithIngredients ourIngredients
+ morley-client-test/Test/Fee.hs view
@@ -0,0 +1,98 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for fee calculation implementation in 'morley-client'.+module Test.Fee+  ( test_FeeCalculation+  ) where++import qualified Data.List.NonEmpty as NE+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++import Morley.Client.Action.Common+  (OriginationData(..), TD(..), TransactionData(..), computeStorageLimit)+import Morley.Client.Action.Operation (dryRunOperationsNonEmpty)+import Morley.Client.Full (runMorleyClientM)+import Morley.Client.RPC.Getters (getProtocolParameters)+import Morley.Client.TezosClient.Impl (calcOriginationFee, calcTransferFee)+import Morley.Client.TezosClient.Types+  (AddressOrAlias(..), CalcOriginationFeeData(..), CalcTransferFeeData(..))+import Morley.Micheline.Json (TezosMutez(..))+import Morley.Michelson.Runtime.GState (genesisAddress)+import Morley.Michelson.Typed (IsoValue(..))+import Morley.Michelson.Untyped (pattern DefEpName)+import Morley.Tezos.Core (toMutez, zeroMutez)+import Test.Cleveland (NetworkEnv(neMorleyClientEnv))+import 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+        }+    ]+  where+    trivialTransfer = TransactionData $ TD+      { tdReceiver = genesisAddress+      , tdAmount = toMutez 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+  (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $+    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (map Left 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+  (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $+    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (one $ Right 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]
+ morley-client-test/Tree.hs view
@@ -0,0 +1,5 @@+-- 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 #-}
+ morley-test/Main.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Cleveland.Ingredients (ourIngredients)+import Test.Cleveland.Tasty (clevelandMainWithIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= clevelandMainWithIngredients ourIngredients
+ morley-test/Test/Analyzer.hs view
@@ -0,0 +1,57 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for analyzer.++module Test.Analyzer+  ( unit_Sample_analyze+  ) where++import Prelude hiding (EQ)++import qualified Data.HashMap.Strict as HM+import Test.HUnit (Assertion, (@?=))++import Morley.Michelson.Analyzer+import Morley.Michelson.Text+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.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)
+ morley-test/Test/Doc/Position.hs view
@@ -0,0 +1,41 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 = ""
+ morley-test/Test/Entrypoints.hs view
@@ -0,0 +1,183 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Data.Map 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 qualified Morley.Michelson.TypeCheck as TC+import Morley.Michelson.Typed+import Morley.Michelson.Untyped (noAnn, unsafeBuildEpName)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Test.Cleveland.Instances ()+import Test.Cleveland.Util (fromHex, runGen, unsafeFromHex)++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 =+      either (error . pretty) id $+      TC.mkSomeParamType (U.ParameterType U.tyunit noAnn)++test_EpAddress :: [TestTree]+test_EpAddress =+  [ testGroup "Parsing" $+    [ testCase "Simple entrypoint" $+        parseEpAddress (formatAddress addr <> "%ab")+          @?= Right (EpAddress addr (unsafeBuildEpName "ab"))++    , testCase "No entrypoint" $+        parseEpAddress (formatAddress addr)+          @?= Right (EpAddress addr DefEpName)++    , testCase "Weird entrypoint" $+        parseEpAddress (formatAddress addr <> "%a%b")+          @?= Right (EpAddress addr (unsafeBuildEpName "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 (unsafeParseEpAddressRaw (unsafeFromHex b)) @?= a)+    | (a, b) <- sampleEpAddresses+    ]+  , [ testCase ("Fails to parse invalid address " <> toString a)+      ((fromHex a >>= rightToMaybe . parseEpAddressRaw) `shouldSatisfy` isNothing)+    | a <- invalidRawEpAddresses+    ]+  ]++test_ParamNotes :: [TestTree]+test_ParamNotes =+  [ testGroup "Duplications are handled" $+    [ testCase "One duplicated entrypoint" $+        mkParamNotes (or "a" "a" prim prim) noAnn+          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| []))+    , testCase "Several duplicated entrypoint" $+        mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn+          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [unsafeBuildEpName "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 $ unsafeBuildEpName "a" :| [DefEpName])+        @?= "Duplicated entrypoint names: 'a', '<default>'"+    , 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| (int %a | nat %b) |]+        @?= Map.fromList+        [ (UnsafeEpName "a", [utypeQ| int |])+        , (UnsafeEpName "b", [utypeQ| nat |])+        ]++  , testCase "Root entrypoint is considered" $+      U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) %root |]+        @?= Map.fromList+        [ (UnsafeEpName "root", [utypeQ| (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"+  ]
+ morley-test/Test/Ext.hs view
@@ -0,0 +1,116 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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)+import Test.Tasty.HUnit (testCase)++import Morley.Michelson.Interpret (MorleyLogs(..), interpret)+import Morley.Michelson.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter)+import Morley.Michelson.TypeCheck+  (HST(..), SomeHST(..), TypeCheckMode(..), runTypeCheck, throwingTCError, typeCheckExt,+  typeCheckInstr, typeCheckingWith, unsafeMkSomeParamType, unsafeWithWTP)+import Morley.Michelson.Typed (epcPrimitive, pattern AsUType)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped+  (ExpandedExtInstr, ExtInstrAbstract(..), ParameterType(..), StackTypePattern(..), T(..), Ty(..),+  TyVar(..), noAnn)+import Test.Cleveland.Instances ()+import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract)+import Test.Util.Contracts++test_PRINT_and_TEST_ASSERT :: IO [TestTree]+test_PRINT_and_TEST_ASSERT = concatTestTrees+  [ testTreesWithTypedContract (inContractsDir "testassert_square.mtz") $+    testAssertSquareImpl+  , testTreesWithTypedContract (inContractsDir "testassert_square2.mtz") $+    testAssertSquareImpl+  ]+  where+    testAssertSquareImpl c = pure+      [ 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 $+                      unsafeMkSomeParamType $+                      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: " <> show e+      _                -> pass
+ morley-test/Test/Import.hs view
@@ -0,0 +1,267 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE QuasiQuotes #-}++-- | Test on importing functionality.+module Test.Import+  ( test_importContract+  , test_importSomeContract+  , test_importUntypedContract+  , test_readContract+  , test_readValue+  , test_Basic+  ) where++import Control.Exception (handle)+import Data.List.NonEmpty ()+import Data.Vinyl (Rec(..))+import Test.HUnit ((@?), (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)++import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos)+import Morley.Michelson.Parser (codeSrc)+import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped as U+import Morley.Util.Interpolate+import Test.Cleveland hiding (importContract, importUntypedContract)+import Test.Cleveland.Instances ()+import Test.Cleveland.Michelson+import Test.Cleveland.Michelson.Import+import Test.Util.Contracts++applyContract :: Contract ('TLambda ('TPair 'TInt 'TInt) 'TInt) 'TInt+applyContract = $$(embedContract (inContractsDir "apply.tz"))++-- | This is a clone of one of the tests but written using 'embedContract'.+test_Basic :: TestTree+test_Basic = testScenarioOnEmulator "" $ scenario do+  hndl <- originateUntypedSimple "apply" (U.ValueInt 0) $ convertContract applyContract+  let+    lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ]+    lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB+  transfer TransferData+    { tdTo = hndl+    , tdAmount = 0+    , tdEntrypoint = DefEpName+    , tdParameter = VLam $ RfNormal lam }+  getStorage @Integer hndl @@== 2++test_readContract :: TestTree+test_readContract = testGroup "Test 'readContract'"+  [ testCase emptyFilePath $+      second convertContract (readContract @'TUnit @'TUnit codeSrc emptyCode) @?=+        Right emptyContractUPrim+  , testCase basic2FilePath $+      second convertContract (+        readContract @TPairInt @TListPairInt codeSrc basic2Code) @?=+          Right basic2ContractUPrim+  , testCase basic3FilePath $+      isLeft (readContract @TPairInt @TListPairInt codeSrc basic3Code)+        @? "Contract should parse"+  ]++test_importContract :: TestTree+test_importContract = testGroup "Test 'importContract'"+  [ testCase emptyFilePath $ do+      contract <- importContract @'TUnit @'TUnit (contractsDir </> emptyFilePath)+      convertContract contract @?= emptyContractUPrim+  , testCase basic2FilePath $ do+      contract <- importContract @TPairInt @TListPairInt (contractsDir </> basic2FilePath)+      convertContract contract @?= basic2ContractUPrim+  , testCase basic3FilePath $ do+      handle @ContractReadError (\_ -> pass) $ do+        _ <- importContract @TPairInt @TListPairInt (contractsDir </> basic3FilePath)+        assertFailure "No exception is raised"+  ]++test_importSomeContract :: TestTree+test_importSomeContract = testGroup "Test 'importSomeContract'"+  [ testCase emptyFilePath $ do+      SomeContract contract <- importSomeContract (contractsDir </> emptyFilePath)+      convertContract contract @?= emptyContractUPrim+  , testCase basic2FilePath $ do+      SomeContract contract <- importSomeContract (contractsDir </> basic2FilePath)+      convertContract contract @?= basic2ContractUPrim+  , testCase basic3FilePath $ do+      handle @ContractReadError (\_ -> pass) $ do+        _ <- importSomeContract (contractsDir </> basic3FilePath)+        assertFailure "No exception is raised"+  ]+++test_importUntypedContract :: TestTree+test_importUntypedContract = testGroup "Test 'importUntypedContract'"+  [ testCase emptyFilePath $ do+      contractU <- importUntypedContract (contractsDir </> emptyFilePath)+      contractU @?= emptyContractU+  , testCase basic2FilePath $ do+      contractU <- importUntypedContract (contractsDir </> basic2FilePath)+      contractU @?= basic2ContractU+  , testCase "Non-parsable contract" $ do+      handle @ContractReadError (\_ -> pass) $ do+        _ <- importUntypedContract (contractsDir </> "unparsable" </> "chain_id_arity.tz")+        assertFailure "No exception is raised"+  ]++test_readValue :: TestTree+test_readValue = testGroup "Test 'readValue'"+  [ testCase "1" $+      (readValue @'TNat codeSrc "1") @?= Right (VNat 1)+  , testCase "{1; 2}" $+      (readValue @('TList 'TString) codeSrc "{\"a\"; \"b\"}") @?=+        Right (VList [VString "a", VString "b"])+  , testCase "Pair 1 \"a\"" $+      (readValue @('TPair 'TInt 'TString) codeSrc "Pair 1 \"a\"") @?=+        Right (VPair (VInt 1, VString "a"))+  , testCase "{something}" $+      isLeft (readValue @'TBool codeSrc "{something}")+        @? "Should parse"+  ]+++-- Contracts' relative filePaths++emptyFilePath :: FilePath+emptyFilePath = "tezos_examples/attic/empty.tz"++basic2FilePath :: FilePath+basic2FilePath = "basic2.tz"++basic3FilePath :: FilePath+basic3FilePath = "ill-typed/basic3.tz"+++-- Text contracts++emptyCode :: Text+emptyCode =+  [itu|+  parameter unit;+  storage unit;+  code {CDR; NIL operation; PAIR}+  |]++basic2Code :: Text+basic2Code =+  [itu|+  parameter (pair (int %x) (int :x));+  storage (list (pair int (int %y)));+  code {+        DUP; CAR; DIP { CDR; };+        CONS;+        NIL operation; PAIR; };+  |]++basic3Code :: Text+basic3Code =+  [itu|+  parameter (pair (int %x) int);+  storage (list (pair (int %z) int));+  code {+        DUP; CAR; DIP { CDR; };+        CONS;+        NIL operation; PAIR; };+  |]+++-- Untyped Michelson contracts++-- We need two versions of each untyped contract for the tests.+-- First is a contract which 'contractCode' is based on 'PrimEx'+-- due to the fact that 'convertContract' uses this constructor+-- to produce untyped contract.+-- Second has 'WithSrcEx' for this purpose+-- because it is a way how untyped contracts are parsed.++emptyContractUPrim :: U.Contract+emptyContractUPrim =+  U.Contract+    { contractParameter = U.ParameterType U.tyunit U.noAnn+    , contractStorage = U.tyunit+    , contractCode = U.PrimEx <$>+        [ U.CDR U.noAnn U.noAnn+        , U.NIL U.noAnn U.noAnn tyoperation+        , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn+        ]+    , entriesOrder = U.PSC+    , contractViews = []+    }++emptyContractU :: U.Contract+emptyContractU =+  U.Contract+    { contractParameter = U.ParameterType U.tyunit U.noAnn+    , contractStorage = U.tyunit+    , contractCode =+        [ locExpanded 2 6  $ U.CDR U.noAnn U.noAnn+        , locExpanded 2 11 $ U.NIL U.noAnn U.noAnn tyoperation+        , locExpanded 2 26 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn+        ]+    , entriesOrder = U.PSC+    , contractViews = []+    }++basic2ContractUPrim :: U.Contract+basic2ContractUPrim =+  U.Contract+    { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn+    , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn+    , contractCode = U.PrimEx <$>+        [ U.DUP U.noAnn+        , U.CAR U.noAnn U.noAnn+        , U.DIP [U.PrimEx $ U.CDR U.noAnn U.noAnn]+        , U.CONS U.noAnn+        , U.NIL U.noAnn U.noAnn tyoperation+        , U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn+        ]+    , entriesOrder = U.PSC+    , contractViews = []+    }++basic2ContractU :: U.Contract+basic2ContractU =+  U.Contract+    { contractParameter = U.ParameterType (U.Ty (U.TPair "x" U.noAnn U.noAnn U.noAnn U.tyint (U.Ty U.TInt "x")) U.noAnn) U.noAnn+    , contractStorage = U.Ty (U.TList (U.Ty (U.TPair U.noAnn "y" U.noAnn U.noAnn U.tyint U.tyint) U.noAnn)) U.noAnn+    , contractCode =+        [ locExpanded 7 6  $ U.DUP U.noAnn+        , locExpanded 7 11 $ U.CAR U.noAnn U.noAnn+        , locExpanded 7 16 $ U.DIP [locExpanded 7 22 $ U.CDR U.noAnn U.noAnn]+        , locExpanded 8 6  $ U.CONS U.noAnn+        , locExpanded 9 6  $ U.NIL U.noAnn U.noAnn tyoperation+        , locExpanded 9 21 $ U.PAIR U.noAnn U.noAnn U.noAnn U.noAnn+        ]+    , entriesOrder = U.PSC+    , contractViews = []+    }+++-- Helpers++locExpanded :: Word -> Word -> U.ExpandedInstr -> U.ExpandedOp+locExpanded line col ei =+  let noCallStack = InstrCallStack [] $ srcPos line col+  in U.WithSrcEx noCallStack $ U.PrimEx ei++locInstr :: Word -> Word -> Instr a b -> Instr a b+locInstr line col = WithLoc $ InstrCallStack [] $ srcPos line col++withNotes+  :: forall a inp out. SingI a+  => Notes a+  -> Instr inp (a : out)+  -> Instr inp (a : out)+withNotes notes = InstrWithNotes Proxy (notes :& RNil)++withVarAnn :: U.VarAnn -> Instr inp out -> Instr inp out+withVarAnn = InstrWithVarAnns . U.OneVarAnn++tyoperation :: U.Ty+tyoperation = U.Ty U.TOperation U.noAnn++type TPairInt = 'TPair 'TInt 'TInt++type TListPairInt = 'TList ('TPair 'TInt 'TInt)
+ morley-test/Test/Integrational.hs view
@@ -0,0 +1,28 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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
+ morley-test/Test/Interpreter.hs view
@@ -0,0 +1,399 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Interpreter+  ( test_basic5+  , test_increment+  , test_fail+  , test_mutez_add_overflow+  , test_mutez_sub_overflow+  , 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 (Buildable(..), (+|), (|+))+import Hedgehog (forAll, property)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage, NiceUnpackedValue)+import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), srcPos)+import Morley.Michelson.Text+import Morley.Michelson.Typed (IsoValue(..), divMich, modMich)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Morley.Tezos.Crypto+import Test.Cleveland+import Test.Cleveland.Internal.Abstract (TransferFailure(..), TransferFailureReason(..))+import Test.Cleveland.Michelson+  (concatTestTrees, testTreesWithTypedContract, testTreesWithUntypedContract)++import Test.Util.Contracts++instance Buildable ByteString where+  build = show++instance Buildable Tuple1 where+  build = show++catchTransferFailureReason :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailureReason+catchTransferFailureReason = fmap tfReason . catchTransferFailure++callSimple+  :: forall cp st caps m.+    ( HasCallStack+    , MonadCleveland caps m+    , HasEntrypointArg cp (EntrypointRef 'Nothing) cp+    , AsRPC st ~ st+    , NiceParameterFull cp, NiceStorage st+    , NiceUnpackedValue (AsRPC st)+    )+  => AliasHint -> T.Contract (ToT cp) (ToT st) -> cp -> st -> m st+callSimple nm contract cp st = do+  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_overflow :: IO [TestTree]+test_mutez_sub_overflow =+  testTreesWithTypedContract (contractsDir </> "mutez_sub_underflow.tz") $ \contract -> pure+  [ testScenarioOnEmulator "Mutez sub underflow test" $ scenario $+      callSimple "mutez_sub_underflow" contract () ()+        & catchTransferFailureReason >>= \case+          MutezArithError T.SubUnderflow -> pass+          x -> failure $ "expecting another failure reason, got " +| x |+ ""+  ]++test_basic1 :: IO [TestTree]+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 =+  testTreesWithUntypedContract (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+  [ testTreesWithUntypedContract (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"])+        ]+    ]+  , testTreesWithUntypedContract (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"+        ]+    ]+  , testTreesWithTypedContract (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+  [ testTreesWithTypedContract (contractsDir </> "access.mtz") $ \contract -> pure+    [ testScenarioOnEmulator "ACCESS instruction" $ scenario $+        callSimple @Tuple1 "access" contract (1, "a", Just "a", Right "a", ["a"]) ()+    ]+  , testTreesWithTypedContract (contractsDir </> "set.mtz") $ \contract -> pure+    [ testScenarioOnEmulator "SET instruction" $ scenario $+      let expected = (2, "za", Just "wa", Right "ya", ["ab"]) :: Tuple1+      in callSimple @_ @Tuple1 "set" contract () (1, "a", Just "a", Right "a", ["a", "b"])+          @@== expected+    ]+  , testTreesWithTypedContract (contractsDir </> "construct.mtz") $ \contract -> pure+    [ 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 () ()+    ]
+ morley-test/Test/Interpreter/Annotations.hs view
@@ -0,0 +1,1076 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 Prelude hiding (Const)++import Control.Lens (ix, makeLensesFor, (<<%=))+import Control.Monad.RWS.Strict (RWST, runRWST)+import qualified Data.List as List+import Data.Map.Strict as Map+import Data.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.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter)+import Morley.Michelson.Runtime.GState (genesisAddress)+import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed (Notes(..), Operation, Value'(..), starNotes, starParamNotes, toVal)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped (noAnn)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address, unsafeParseAddress)+import Morley.Tezos.Core (toMutez)+import Morley.Util.Sing (eqParamSing)+import Test.Cleveland.Instances ()+import Test.Cleveland.Michelson (importContract)+import qualified Text.Show+import qualified Unsafe++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 -> show x <> " :& " <> 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 :: TestInstrRunner+runInstrTest = runInstrTestImpl False++runInstrTestImpl :: 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+  :: 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+  :: 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 = T.NTInt "y"++    param = "parameter"++    expectedStacksIF_NONE_None :: [Maybe SomeStack]+    expectedStacksIF_NONE_None =+      [ -- CAR+        someStack $ StkEl (T.VOption @'T.TInt Nothing) param (T.NTOption U.noAnn y) :& RNil+        -- 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 (T.NTOption U.noAnn 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 (T.NTOr U.noAnn U.noAnn U.noAnn y 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 (T.NTOr U.noAnn U.noAnn U.noAnn y 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 (T.NTList U.noAnn 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 (T.NTList U.noAnn 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 =+      T.NTPair "q" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "x") (T.NTInt "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"+        (T.NTPair "p" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "a") (T.NTInt "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 = T.NTInt "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 = T.NTInt "y"++    yv :: U.VarAnn+    yv = "y"++    list :: T.Notes ('T.TList 'T.TInt)+    list = T.NTList "list" T.starNotes++    listv :: U.VarAnn+    listv = "list"++    expectedStacksMap :: [Maybe SomeStack]+    expectedStacksMap =+      [ -- DROP+        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]) listv list :& 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 (T.NTList U.noAnn 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 = T.NTMap "m" k (T.NTInt "v")++    k :: T.Notes 'T.TInt+    k = T.NTInt "k"++    v :: T.Notes ('T.TOption 'T.TInt)+    v = T.NTOption U.noAnn $ T.NTInt "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 = unsafeParseAddress "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 $ toMutez 100++    contract :: T.Value 'T.TOperation+    contract = T.VOp $ T.OpCreateContract T.CreateContract+      { T.ccOriginator = genesisAddress+      , T.ccDelegate = Nothing+      , T.ccBalance = toMutez 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 =+      NTPair noAnn+        "aa" noAnn+        noAnn noAnn+        (NTInt "a")+        (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c"))++    pairNotes' =+      NTPair noAnn+      noAnn noAnn+      noAnn noAnn+      (NTInt "a")+      (NTPair noAnn noAnn noAnn noAnn noAnn (NTInt "b") (NTInt "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" (NTInt "a") :&+          StkEl (toVal @Integer 5) "bb" (NTInt "b") :&+          StkEl (toVal @Integer 6) "cc" (NTInt "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 =+      NTPair noAnn+        "aa" noAnn+        noAnn noAnn+        (NTInt "a")+        (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c"))++    storageNotes =+      NTPair noAnn "aa" "bb" noAnn noAnn (NTInt "a") (NTInt "b")++    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 (NTInt "b") :&+          StkEl (toVal param) "parameter" paramNotes :&+          RNil+        -- SWAP;+      , someStack $+          StkEl (toVal param) "parameter" paramNotes :&+          StkEl (toVal @Integer 2) noAnn (NTInt "b") :&+          RNil+        -- GET @aa 1+      , someStack $+          StkEl (toVal @Integer 1) "aa" (NTInt "a") :&+          StkEl (toVal @Integer 2) noAnn (NTInt "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" (NTInt "i") :&+          RNil+        -- GET 0;+      , someStack $+          StkEl (toVal @Integer 1) noAnn (NTInt "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 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) (Pair 0 "a" Unit);+      , someStack $+          StkEl+            (toVal (0 :: Integer, ("a" :: MText, ())))+            noAnn+            (NTPair "t0" "f1" "" "" "" (NTInt "t1") (NTPair "" "f2" "f3" "" "" (NTString "t2") (NTUnit "t3"))) :&+          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+            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f2" "f3" "" "" (NTNat "t5") (NTNat "t6"))) :&+          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+            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f7" "f8" "" "" (NTNat "t7") (NTNat "t8"))) :&+          RNil++        -- PUSH (nat :t9) 0;+        -- UPDATE 2;+      , ignoreStack+      , someStack $+          StkEl+            (toVal (0 :: Natural, 0 :: Natural))+            noAnn+            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTNat "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" (NTOption "" (NTNat "v")) :&+          StkEl (toVal (one (1, 1) :: Map Integer Natural)) "varMap" (NTMap "map" (NTInt "k") (NTNat "v")) :&+          RNil++        -- PUSH @varKey (int :k) 1;+        -- GET_AND_UPDATE @newVarMap;+      , ignoreStack+      , someStack $+          StkEl (toVal (Just 1 :: Maybe Natural))       "varVal"    (NTOption "" (NTNat "v")) :&+          StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" (NTMap "map" (NTInt "k") (NTNat "v")) :&+          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 (NTPair noAnn noAnn noAnn noAnn noAnn starNotes x) :& RNil)+    expectedStacks+  where+    store :: T.Value 'T.TInt+    store = T.VInt 42++    x :: T.Notes 'T.TInt+    x = T.NTInt "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 = NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTUnit "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" (NTUnit "last") :& RNil+        -- CDR @kek 2 (macro expanded above)+      , someStack $ StkEl VUnit "kek" (NTUnit "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" (NTUnit noAnn) :& RNil+        -- RIGHT % %@ never+      , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" (NTOr noAnn noAnn "y" (NTNever "") (NTUnit "")) :& RNil+        -- DROP+        -- PUSH unit Unit+        -- NUL operation+        -- PAIR+      , ignoreStack, ignoreStack, ignoreStack, ignoreStack+      ]
+ morley-test/Test/Interpreter/Apply.hs view
@@ -0,0 +1,52 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# 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 Fmt (Buildable(..))+import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped as U+import Test.Cleveland+import Test.Cleveland.Util (unsafeFromHex)++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 = unsafeFromHex "05020000000f0743035b0005034202000000020316"+  transfer TransferData+    { tdTo = handle+    , tdAmount = 0+    , tdEntrypoint = DefEpName+    , tdParameter = () }+  getStorage @ByteString handle @@== expected++instance Buildable ByteString where+  build = show
+ morley-test/Test/Interpreter/Auction.hs view
@@ -0,0 +1,149 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Hedgehog.Gen.Tezos.Core (genMutez', genTimestamp, midTimestamp)+import Hedgehog.Gen.Tezos.Crypto (genKeyHash)+import Morley.Tezos.Address (Address(..))+import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, toMutez, unMutez, unsafeMkMutez)+import Morley.Tezos.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, (toMutez 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 = unsafeMkMutez <$> Gen.word64 (Range.constant (midAmount' - 4) (midAmount' + 4))+    midAmount = maxMutez `div` 2+    midAmount' = unMutez midAmount+    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: " <> show 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
+ morley-test/Test/Interpreter/Balance.hs view
@@ -0,0 +1,107 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Interpreter.Balance+  ( test_balanceIncludesAmount+  , test_balanceIncludesAmountComplexCase+  ) where++import Hedgehog (Gen, forAll, property, withTests)+import qualified Hedgehog.Gen as Gen+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped 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 <- toMutez <$> Gen.enum 1000 5000+  fAmount <- toMutez <$> 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 = (toMutez 0)+                , uodStorage = (untypeValue $ toVal @[Mutez] [])+                , uodContract = contractA+                }+            let+              origDataB = UntypedOriginateData+                { uodName = "balance_test_case_b"+                , uodBalance = (toMutez 0)+                , uodStorage = (untypeValue $ toVal ())+                , uodContract = contractB+                }+            addressA <- originateUntyped origDataA+            addressB <- originateUntyped origDataB+            let+              transferData = TransferData+                { tdTo = addressA+                , tdAmount = toMutez 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 = [toMutez 75, toMutez 100]+            getStorage @[Mutez] addressA @@== expectedStorage+        ]
+ morley-test/Test/Interpreter/CallSelf.hs view
@@ -0,0 +1,84 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen as Gen+import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.Hedgehog (testProperty)+import qualified Unsafe (fromIntegral)++import Morley.Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..))+import Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped 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
+ morley-test/Test/Interpreter/CallSelfAddress.hs view
@@ -0,0 +1,59 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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"))
+ morley-test/Test/Interpreter/ComparableSet.hs view
@@ -0,0 +1,50 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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
+ morley-test/Test/Interpreter/Compare.hs view
@@ -0,0 +1,88 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen.Michelson.Untyped as U+import Hedgehog.Gen.Tezos.Core (genMutez)+import Morley.Michelson.Interpret (ContractReturn)+import Morley.Michelson.TypeCheck.Types (getWTP')+import Morley.Michelson.Typed (ToT, fromVal)+import qualified Morley.Michelson.Typed as T+import Morley.Tezos.Core (Mutez, toMutez)+import 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 (toMutez 10, toMutez 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, 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
+ morley-test/Test/Interpreter/ComparePairs.hs view
@@ -0,0 +1,47 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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, toMutez)+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+          ( (toMutez 10, toMutez 11)+          , (toMutez 10, toMutez 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]
+ morley-test/Test/Interpreter/Conditionals.hs view
@@ -0,0 +1,61 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Module, containing spec to test conditionals.tz contract.+module Test.Interpreter.Conditionals+  ( test_conditionals+  ) where++import Hedgehog (forAll, property)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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"))
+ morley-test/Test/Interpreter/ContractOp.hs view
@@ -0,0 +1,73 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module, containing spec to test contract_op.tz contract.+module Test.Interpreter.ContractOp+  ( test_contract_op+  ) where++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 '" <> show 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
+ morley-test/Test/Interpreter/CreateAndReverseOps.hs view
@@ -0,0 +1,37 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"
+ morley-test/Test/Interpreter/CreateAndTransfer.hs view
@@ -0,0 +1,29 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"
+ morley-test/Test/Interpreter/EnvironmentSpec.hs view
@@ -0,0 +1,98 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for the 'environment.tz' contract++module Test.Interpreter.EnvironmentSpec+  ( test_environment+  ) where++import Hedgehog (Gen, forAll, property, withTests)+import qualified Hedgehog.Gen as Gen+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Morley.Michelson.Runtime.GState+import Morley.Michelson.Typed+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.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 <- toMutez <$> Gen.enum 1 1234+  fAmount <- toMutez <$> 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 > toMutez 1000 ->+              expectFailedWith balanceAfterTransfer $+                transfer transferData+          | fPassOriginatedAddress fixture ->+              expectFailedWith environmentAddress $+                transfer transferData+          | fAmount fixture < toMutez 15 ->+              expectFailedWith (fAmount fixture) $+                transfer transferData+          | otherwise -> transfer transferData
+ morley-test/Test/Interpreter/Print.hs view
@@ -0,0 +1,100 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Morley.Michelson.Typed 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 <default>: × }"]++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
+ morley-test/Test/Interpreter/Reference.hs view
@@ -0,0 +1,316 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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.Client (RunError(..), runMorleyClientM)+import Morley.Client.RPC (RunCodeErrors(..))+import Morley.Client.RPC.AsRPC (AsRPC, rpcStorageScopeEvi, valueAsRPC)+import Morley.Client.Util as Reference (RunContractParameters(..), runContract)+import Morley.Michelson.Interpret+  (InterpretError(..), MichelsonFailed(..), MichelsonFailureWithStack(..))+import Morley.Michelson.Runtime as Morley+import Morley.Michelson.Runtime.GState (genesisAddress)+import Morley.Michelson.TypeCheck (TypeCheckOptions(..), withWTPm)+import Morley.Michelson.Typed+  (Contract, Contract'(..), EpAddress(..), SingT(..), SomeContract(..), SomeStorage(..), Value,+  Value'(..), dfsMapValue)+import Morley.Michelson.Typed.Arith (ArithError(..), MutezArithErrorType(..))+import Morley.Michelson.Typed.Convert+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Morley.Tezos.Core+  (Timestamp(..), dummyChainId, getCurrentTime, toMutez, unsafeMkMutez, 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.+     ]++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+          -- TODO [#392]: this check have to become unnecessary+          withWTPm @st $ do+            withWTPm @cp $ 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 = parameter+              , rcpStorage = storage+              , rcpBalance = unsafeMkMutez 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 toMutez 50000 else minBound+        resMorley <- try @_ @ExecutorError $ silence $+          Morley.runContract (Just currentTimestamp) (Just 0) 100500 (unsafeMkMutez 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 (AsRPC st) -> Value st -> m ()+compareValues storageReference storageMorley =+  preprocessValue storageReference === preprocessValue (valueAsRPC storageMorley)+  where+    preprocessValue :: Value (AsRPC st) -> Value (AsRPC 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 (AsRPC t) -> Value (AsRPC 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+      MutezArithError SubUnderflow _ _ ->+        assertRpcErrs errs+        (\case+            MutezSubtractionUnderflow {} -> True+            _ -> False+        ) $ "Morley interpreter failed with mutez subtraction underflow, \+            \however reference interpreter failed with:\n" <> displayException rpcErr+    MichelsonGasExhaustion ->+      assertRpcErrs errs+      (\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
+ morley-test/Test/Interpreter/SetDelegate.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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
+ morley-test/Test/Interpreter/StackRef.hs view
@@ -0,0 +1,37 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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
+ morley-test/Test/Interpreter/StringCaller.hs view
@@ -0,0 +1,101 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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|]
+ morley-test/Test/Interpreter/TransferAndCreate.hs view
@@ -0,0 +1,33 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"
+ morley-test/Test/Interpreter/Views.hs view
@@ -0,0 +1,139 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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, NicePackedValue 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
+ morley-test/Test/Macro.hs view
@@ -0,0 +1,222 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Gen.Michelson.Untyped as Gen.U+import qualified Hedgehog.Range 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'(..), noAnn, unsafeMkAnnotation)++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 = unsafeMkAnnotation <$> ["field1", "field2", "field3"]+    n = noAnn+    f = "field"+    leaf f' = F (unsafeMkAnnotation 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
+ morley-test/Test/Michelson/Parser/Value.hs view
@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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
+ morley-test/Test/Michelson/Runtime.hs view
@@ -0,0 +1,172 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..))+import Morley.Tezos.Address+import Morley.Tezos.Core (toMutez)+import Test.Cleveland.Instances ()++test_executorPure :: IO [TestTree]+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 = toMutez 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 = toMutez 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}
+ morley-test/Test/Michelson/Text.hs view
@@ -0,0 +1,167 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on 'MText'.+module Test.Michelson.Text+  ( test_Roundtrip+  , unit_mkMText+  , unit_parse+  , unit_mkMTextCut+  , unit_QuasiQuoter+  , unit_mt+  ) where++import Fmt (pretty)+import Test.HUnit (Assertion, (@?), (@?=))+import Test.Tasty (TestTree)+import qualified Text.Megaparsec as P++import Hedgehog.Gen.Michelson (genMText)+import Morley.Michelson.Parser+import Morley.Michelson.Text+import qualified Morley.Michelson.Untyped 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.+(@??) :: (Show a, HasCallStack) => a -> (a -> Bool) -> Assertion+(@??) val predicate =+  predicate val @?+  ("Predicate does not hold for value " <> show 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  "
+ morley-test/Test/Michelson/Typed/AnnotatedValue.hs view
@@ -0,0 +1,261 @@+-- SPDX-FileCopyrightText: 2022 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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+import Fmt (Buildable, GenericBuildable(..))+import Test.Cleveland.Instances ()+import Test.Tasty.HUnit++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 =+  NTOr "" "" ""+    (NTOr "" "p1" "p2" starNotes starNotes)+    (NTOr "" "p3" "p4" starNotes nestedParamNotes)++nestedParamNotes :: Notes (ToT NestedParam)+nestedParamNotes =+  NTOr "" "p1" "p2" starNotes starNotes++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 =+  NTPair "" "" "" "" ""+    (NTPair "" "field1" "field2" "" "" starNotes starNotes)+    (NTPair "" "field3" "field4" "" "" starNotes nestedNotes)++nestedNotes :: Notes (ToT Nested)+nestedNotes =+  NTPair "" "field1" "field2" "" "" starNotes starNotes++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+          (NTPair "" "field1" "field2" "" "" starNotes starNotes)+          (toVal @(Integer, (MText, Natural)) $ (1, ("a", 2)))+      )+    , ("", SomeAnnotatedValue+          (NTPair "" "field3" "field4" "" "" starNotes (NTPair "" "field1" "field2" "" "" starNotes starNotes) )+          (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 =+  NTPair "" "listField" "" "" ""+    starNotes+    (NTPair "" "mapField" "bigMapField" "" "" starNotes starNotes)++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
+ morley-test/Test/Michelson/Typed/Convert.hs view
@@ -0,0 +1,75 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on 'Convert'.+module Test.Michelson.Typed.Convert+  ( test_sub+  , test_sha+  , test_arith+  ) where++import Test.HUnit (assertEqual)+import Test.Hspec ()+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Morley.Michelson.Typed.Convert (instrToOps)+import Morley.Michelson.Typed.Instr (Instr(..))+import qualified Morley.Michelson.Typed.Instr as T (Instr(EQ, GE, GT, LE, LT, NEQ))+import Morley.Michelson.Typed.Value (Value'(..))+import qualified Morley.Michelson.Untyped as U+import 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_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]
+ morley-test/Test/Michelson/Typed/Util.hs view
@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for 'Morley.Michelson.Typed.Util'.++module Test.Michelson.Typed.Util+  ( unit_linearizeLeft_sample+  , hprop_linearizeLeft_performance+  , unit_dfsInstr_counter+  , unit_dfsInstr_meta+  ) where++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 =+      DfsSettings+      { dsGoToValues = goToValues+      , dsCtorEffectsApp = ceaBottomToTop+      }++    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) = dfsInstr 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 -> (Instr i o, Product Word)+    go = \case+      Meta (SomeMeta m) i | Just (v :: Word) <- cast m -> (i, Product v)+      i -> (i, mempty)
+ morley-test/Test/Michelson/Typed/Value.hs view
@@ -0,0 +1,36 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)+  ]
+ morley-test/Test/Morley/Expression.hs view
@@ -0,0 +1,556 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 Data.Aeson+  (FromJSON, Result(Error, Success), ToJSON(toJSON), Value(String), eitherDecode, encode, fromJSON,+  object, (.=))+import Data.Aeson.QQ (aesonQQ)+import Data.Default (def)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import qualified Data.Set as Set+import Data.Singletons (demote)+import qualified Data.Text 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 qualified Hedgehog.Gen.Morley.Micheline as M+import qualified Morley.Micheline as M+import Morley.Michelson.Text (MText)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Core (Mutez)+import Test.Cleveland.Instances ()+import Test.Cleveland.Util (unsafeFromHex)+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 (unsafeFromHex "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 (unsafeFromHex "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 (unsafeFromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")++  , testCase "Converting VChainId to Expression" $+      M.toExpression @(T.Value 'T.TChainId) (getSampleValue @('T.TChainId)) `shouldBe`+        M.ExpressionBytes (unsafeFromHex "458aa837")++  , testCase "Converting VSignature to Expression" $+      M.toExpression @(T.Value 'T.TSignature) (getSampleValue @('T.TSignature)) `shouldBe`+        (M.ExpressionBytes $ unsafeFromHex+          "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd89\+          \1cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201")++  , testCase "Converting VKeyHash to Expression" $+      M.toExpression @(T.Value 'T.TKeyHash) (getSampleValue @('T.TKeyHash)) `shouldBe`+        M.ExpressionBytes (unsafeFromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d")++  , testCase "Converting VBls12381Fr to Expression" $+      M.toExpression @(T.Value 'T.TBls12381Fr) (getSampleValue @('T.TBls12381Fr)) `shouldBe`+          M.ExpressionBytes (unsafeFromHex "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 (T.NTPair "pair" "a" "b" U.noAnn U.noAnn (T.NTString U.noAnn) (T.NTInt "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 = fromJust $ T.sampleTypedValue $ T.sing @t
+ morley-test/Test/OpSize.hs view
@@ -0,0 +1,278 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for operation size evaluation.++module Test.OpSize+  ( test_Nesting+  , test_Numbers+  , test_Values+  , test_Types+  , test_Instructions+  ) where++import Prelude hiding (EQ)++import qualified Data.Text 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 qualified Hedgehog.Gen.Tezos.Crypto.Ed25519 as Ed25519+import qualified Hedgehog.Gen.Tezos.Crypto.Secp256k1 as Secp256k1+import Morley.Michelson.Macro+import qualified Morley.Michelson.Parser as Parser+import Morley.Michelson.Typed+import Morley.Michelson.Untyped (unsafeBuildEpName)+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) (unsafeBuildEpName "a")+      in valueTestCaseExt "short entrypoint" "address" (dquotes $ pretty epAddr) 49+    , let epAddr = EpAddress (gen genAddress) (unsafeBuildEpName . 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 (show 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 (show instr) instr gas++  instrTestCaseFailWith instr gas =+    instrTestCase (instr <> "; FAILWITH") gas
+ morley-test/Test/Optimizer.hs view
@@ -0,0 +1,275 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Data.Text.IO.Utf8 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.Text+import Morley.Michelson.TypeCheck (mapSomeContract)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Untyped.Annotation (noAnn)+import Morley.Util.PeanoNatural (PeanoNatural(..))+import Test.Cleveland.Instances ()+import Test.Cleveland.Michelson (importSomeContract)++import Test.Util.Contracts+import Test.Util.HUnit+++-- 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 <- importSomeContract 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)
+ morley-test/Test/Parser.hs view
@@ -0,0 +1,423 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Parser+  ( unit_Parse_contracts+  , unit_Parse_bad_contracts+  , unit_Value+  , unit_string_literal+  , unit_annotation+  , unit_IF+  , unit_MAP+  , unit_PAIR+  , unit_UNPAIR+  , unit_pair_type+  , unit_Right_combed_pair_type+  , unit_Right_combed_pair_type_with_annotations+  , unit_tuple_type+  , unit_or_type+  , unit_lambda_type+  , unit_list_type+  , unit_set_type+  , unit_Pair_constructor+  , unit_Right_combed_Pair_constructor+  , unit_PrintComment+  , unit_ParserException+  , unit_letType+  , unit_block_comment+  , unit_UNPAPAIR+  ) where++import qualified Data.List.NonEmpty as NE+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)+import 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.Untyped as Mo+import Morley.Util.Positive+import Test.Cleveland.Instances ()+import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts)++unit_Parse_contracts :: Expectation+unit_Parse_contracts = do+  files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts+  mapM_ (checkFile True) files++unit_Parse_bad_contracts :: Expectation+unit_Parse_bad_contracts = do+  files <- getUnparsableContracts+  mapM_ (checkFile False) files++checkFile :: Bool -> FilePath -> Expectation+checkFile shouldParse file = do+  code <- Utf8.readFile file+  case parse P.program file code of+    Left err+      | shouldParse -> expectationFailure $ errorBundlePretty err+    Right _+      | not shouldParse -> expectationFailure $ "Managed to parse " <> file+    _ -> pass++unit_Value :: Expectation+unit_Value = do+  P.parseNoEnv P.value codeSrc "{}" `shouldBe`+    Right Mo.ValueNil+  P.parseNoEnv P.value codeSrc "{PUSH int 5;}" `shouldBe`+    (Right . ValueLambda $ NE.fromList+      [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]+    )+  P.parseNoEnv P.value codeSrc "{1; 2}" `shouldBe`+    (Right . Mo.ValueSeq $ NE.fromList+      [Mo.ValueInt 1, Mo.ValueInt 2]+    )+  P.parseNoEnv P.value codeSrc "{Elt 1 2; Elt 3 4}" `shouldBe`+    (Right . Mo.ValueMap $ NE.fromList+      [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]+    )+  P.parseNoEnv P.value codeSrc "{DIP DROP;}" `shouldBe`+    Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))+  P.parseNoEnv P.value codeSrc "{DIP DROP;somecontent}" `shouldSatisfy` isLeft+  P.parseNoEnv P.value codeSrc "{{ }; {}; {PUSH int 5; DROP}}" `shouldBe`+    Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1)+            :| [ Mo.Seq [] (srcPos 0 6)+               , Mo.Seq [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)+                        , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)+               ]+           ))+  P.parseNoEnv P.value codeSrc "{{}; {}; {5}}" `shouldBe`+    Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))+  P.parseNoEnv P.value codeSrc "{{}; {5}; {Push int 5}}" `shouldSatisfy` isLeft++unit_string_literal :: Expectation+unit_string_literal = do+  P.parseNoEnv P.stringLiteral codeSrc "\"\"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral codeSrc "\" \\n  \"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft+  P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft++unit_annotation :: Expectation+unit_annotation = do+  P.parseNoEnv PA.noteV codeSrc "@" `shouldSatisfy` isRight+  P.parseNoEnv PA.noteV codeSrc "@_" `shouldSatisfy` isRight+  P.parseNoEnv PA.noteV codeSrc "@a." `shouldSatisfy` isRight+  P.parseNoEnv PA.noteV codeSrc "@7a" `shouldSatisfy` isRight+  P.parseNoEnv PA.noteV codeSrc "@.a" `shouldSatisfy` isLeft+  P.parseNoEnv PA.noteV codeSrc "@@@" `shouldSatisfy` isLeft+  P.parseNoEnv PA.noteV codeSrc "@a b" `shouldSatisfy` isLeft+  P.parseNoEnv PA.noteV codeSrc "@a\\" `shouldSatisfy` isLeft+  -- TODO [#48] these are special annotations and should not always be accepted+  P.parseNoEnv PA.noteV codeSrc "@%" `shouldSatisfy` isRight+  P.parseNoEnv PA.noteV codeSrc "@%%" `shouldSatisfy` isRight++unit_IF :: Expectation+unit_IF = do+  P.parseNoEnv P.codeEntry codeSrc "{IF {} {};}" `shouldBe`+    Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry codeSrc "{IFEQ {} {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry codeSrc "{IFCMPEQ {} {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]++unit_MAP :: Expectation+unit_MAP = do+  parseNoEnv P.codeEntry codeSrc "{MAP {};}" `shouldBe`+    Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]+  parseNoEnv P.codeEntry codeSrc "{MAP_CAR {};}" `shouldBe`+    Prelude.Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]++unit_PAIR :: Expectation+unit_PAIR = do+  P.parseNoEnv P.codeEntry codeSrc "{PAIR;}" `shouldBe`+    Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry codeSrc "{PAIR %a;}" `shouldBe`+    Prelude.Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry codeSrc "{PAIR %0;}" `shouldBe`+    Prelude.Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]+  P.parseNoEnv P.codeEntry codeSrc "{PAPAIR;}" `shouldBe`+    Prelude.Right+      [flip Mac (srcPos 0 1) $+        PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))+          noAnn noAnn+      ]++unit_UNPAPAIR :: Expectation+unit_UNPAPAIR = do+  let unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1)++  P.parseNoEnv P.codeEntry "" "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}" `shouldBe`+    Prelude.Right [unpapair]++  P.parseNoEnv P.codeEntry "" "{UNPAPAIR @a %b @c %d %e @f;}" `shouldBe`+    Prelude.Right [unpapair]++  P.parseNoEnv P.codeEntry "" "{UNPAPAIR;}" `shouldBe`+    Prelude.Right [unpapair]++unit_UNPAIR :: Expectation+unit_UNPAIR = do+  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %a;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a %b;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %b @a;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c %d;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]++  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a @b;}" `shouldBe`+    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]++  -- 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 ('@' :| ""))++unit_pair_type :: Expectation+unit_pair_type = do+  P.parseNoEnv P.type_ codeSrc "pair unit unit" `shouldBe` Right unitPair+  P.parseNoEnv P.type_ codeSrc "(unit, unit)" `shouldBe` Right unitPair+  P.parseNoEnv P.type_ codeSrc "(key, (int, (string, bool)))"+    `shouldSatisfy` isRight+  P.parseNoEnv P.type_ codeSrc "(signature, chain_id, string, bool)"+    `shouldSatisfy` isRight+  where+    unitPair :: Mo.Ty+    unitPair =+      Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn++unit_Right_combed_pair_type :: Expectation+unit_Right_combed_pair_type = do+  P.parseNoEnv P.type_ codeSrc "pair unit int string" `shouldBe` Right rightCombPair+  P.parseNoEnv P.type_ codeSrc "(unit, int, string)" `shouldBe` Right rightCombPair+  where+    rightCombPair :: Mo.Ty+    rightCombPair =+      Mo.Ty+        (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++unit_Right_combed_pair_type_with_annotations :: Expectation+unit_Right_combed_pair_type_with_annotations = do+  P.parseNoEnv P.type_ codeSrc "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)" `shouldBe` Right rightCombPairWithAnns+  P.parseNoEnv P.type_ codeSrc "(unit :t1 %x, int :t2 %y, string %z :t3) :t" `shouldBe` Right rightCombPairWithAnns+  where+    rightCombPairWithAnns :: Mo.Ty+    rightCombPairWithAnns =+      Mo.Ty+        (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"++unit_tuple_type :: Expectation+unit_tuple_type = do+  P.parseNoEnv P.type_ codeSrc "(int, int, bool, unit, nat)"+    `shouldBe` Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))+  P.parseNoEnv P.type_ codeSrc+    "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))"+      `shouldBe` Right (bigPair 16)+  where+    bigPair :: Integer -> Ty+    bigPair n | n == 0 = tynat+    bigPair n          = typair tynat (bigPair (n - 1))++unit_or_type :: Expectation+unit_or_type = do+  P.parseNoEnv P.type_ codeSrc "or unit unit" `shouldBe` Right unitOr+  P.parseNoEnv P.type_ codeSrc "(unit | unit)" `shouldBe` Right unitOr+  P.parseNoEnv P.type_ codeSrc "(chain_id | (int | (string | bool)))"+    `shouldSatisfy` isRight+  P.parseNoEnv P.type_ codeSrc "or unit unit kek"+    `shouldSatisfy` isLeft+  where+    unitOr :: Mo.Ty+    unitOr =+      Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn++unit_lambda_type :: Expectation+unit_lambda_type = do+  P.parseNoEnv P.type_ codeSrc "lambda unit unit" `shouldBe` Right lambdaUnitUnit+  P.parseNoEnv P.type_ codeSrc "\\unit -> unit" `shouldBe` Right lambdaUnitUnit+  P.parseNoEnv P.type_ codeSrc "lambda int (signature, int)" `shouldSatisfy` isRight+  where+    lambdaUnitUnit :: Mo.Ty+    lambdaUnitUnit =+      Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn++unit_list_type :: Expectation+unit_list_type = do+  P.parseNoEnv P.type_ codeSrc "list unit" `shouldBe` Right unitList+  P.parseNoEnv P.type_ codeSrc "[unit]" `shouldBe` Right unitList+  P.parseNoEnv P.type_ codeSrc "[(key, key)]" `shouldSatisfy` isRight+  where+    unitList :: Mo.Ty+    unitList =+      Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn++unit_set_type :: Expectation+unit_set_type = do+  P.parseNoEnv P.type_ codeSrc "set int" `shouldBe` Right intSet+  P.parseNoEnv P.type_ codeSrc "set (pair int int)" `shouldBe` Right intPairSet+  P.parseNoEnv P.type_ codeSrc "{int}" `shouldBe` Right intSet+  P.parseNoEnv P.type_ codeSrc "{(pair int int)}" `shouldBe` Right intPairSet+  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++unit_Pair_constructor :: Expectation+unit_Pair_constructor = do+  P.parseNoEnv P.value codeSrc "Pair Unit Unit" `shouldBe` Right unitPair+  P.parseNoEnv P.value codeSrc "(Unit, Unit)" `shouldBe` Right unitPair+  where+    unitPair :: Mo.Value' Mo.ParsedOp+    unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit++unit_Right_combed_Pair_constructor :: Expectation+unit_Right_combed_Pair_constructor = do+  P.parseNoEnv P.value codeSrc "Pair Unit 3 \"Hi\"" `shouldBe` Right unitPair+  P.parseNoEnv P.value codeSrc "(Unit, 3, \"Hi\")" `shouldBe` Right unitPair+  where+    unitPair :: Mo.Value' Mo.ParsedOp+    unitPair = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi"))++unit_PrintComment :: Expectation+unit_PrintComment = do+  P.parseNoEnv P.printComment codeSrc "\"Sides are %[0] x %[1]\"" `shouldBe`+    Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])+  P.parseNoEnv P.printComment codeSrc "\"%[0] x\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Left " x"])+  P.parseNoEnv P.printComment codeSrc "\"%[0]x%[1]\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])+  P.parseNoEnv P.printComment codeSrc "\"%[0]%[1]\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])+  P.parseNoEnv P.printComment codeSrc "\"xxx\"" `shouldBe`+    Right (PrintComment [Left "xxx"])+  P.parseNoEnv P.printComment codeSrc "\"\"" `shouldBe`+    Right (PrintComment [])++unit_ParserException :: Expectation+unit_ParserException = do+  handleCustomError "0x000" P.value OddNumberBytesException+  handleCustomError "Right 0x000" P.value OddNumberBytesException+  handleCustomError "\"aaa\\r\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 'r'))+  handleCustomError "\"aaa\\b\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 'b'))+  handleCustomError "\"aaa\\t\"" P.stringLiteral+    (StringLiteralException (InvalidEscapeSequence 't'))+  handleCustomError "\"aaa\n\"" P.stringLiteral+    (StringLiteralException (InvalidChar '\n'))+  handleCustomError "\"aaa\r\"" P.stringLiteral+    (StringLiteralException (InvalidChar '\r'))+  handleCustomError "{ TAG 2 (int | string) }" P.codeEntry+    (WrongTagArgs 2 (UnsafePositive 2))+  handleCustomError "{ ACCESS 2 2 }" P.codeEntry+    (WrongAccessArgs 2 (UnsafePositive 2))+  handleCustomError "{ SET 2 2 }" P.codeEntry+    (WrongSetArgs 2 (UnsafePositive 2))+  handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };"+    (P.letInner P.parsedOp)+    (Tokens ('n' :| ""))++handleCustomError+  :: HasCallStack => Text -> Parser a -> CustomParserException -> Expectation+handleCustomError text parser customException =+  case P.parseNoEnv parser codeSrc text of+    Right _ -> expectationFailure "expecting parser to fail"+    Left bundle -> case toList $ bundleErrors bundle of+      [FancyError _ (toList -> [ErrorCustom e])] ->+        e `shouldBe` customException+      _ ->+        expectationFailure $+          "expecting single ErrorCustom, but got " <>+          errorBundlePretty bundle++handleTrivialError+  :: HasCallStack => Text -> Parser a -> ErrorItem Char -> Expectation+handleTrivialError text parser errorItem =+  case P.parseNoEnv parser codeSrc text of+    Right _ -> expectationFailure "expecting parser to fail"+    Left bundle -> case toList $ bundleErrors bundle of+      [TrivialError _ e _] ->+        e `shouldBe` (Just errorItem)+      _ ->+        expectationFailure $+          "expecting single TrivialError, but got " <>+          errorBundlePretty bundle++unit_letType :: Expectation+unit_letType = do+  P.parseNoEnv P.letType codeSrc "type kek = int" `shouldSatisfy` isRight+  -- They used to be prohibited, but now we permit them.+  P.parseNoEnv P.letType codeSrc "type Parameter = int" `shouldSatisfy` isRight+  P.parseNoEnv P.letType codeSrc "type Storage = int" `shouldSatisfy` isRight++unit_block_comment :: Expectation+unit_block_comment =+  forM_ validBlockComments $ \blockComment ->+    P.parseNoEnv PL.mSpace codeSrc blockComment `shouldBe` Right ()+  where+    validBlockComments =+      [ "/* */"+      , " /* */"+      , "/* */ "+      , "/* */;"+      , "/* */ ;"+      , "/* */\n;"+      ]
+ morley-test/Test/Preprocess.hs view
@@ -0,0 +1,63 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Untyped.Annotation (noAnn)++unit_Sample_preprocess :: Assertion+unit_Sample_preprocess = do+  transformStrings False (f (unsafeMkMText . toText)) (sample (T.VString . unsafeMkMText)) @?= (expected (T.VString . unsafeMkMText))+  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"
+ morley-test/Test/Printer/Michelson.hs view
@@ -0,0 +1,129 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Printer.Michelson+  ( unit_Roundtrip+  , unit_let_macro+  , unit_PrettyPrint+  , unit_PrintTypedNotes+  , unit_PrintSmartParens+  , unit_PrintBigDipN+  , unit_Views+  ) where++import qualified Data.Text.IO.Utf8 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 (parseExpandContract)+import qualified Morley.Michelson.Untyped 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 <- importUntypedContract 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 =<< importUntypedContract filePath+  let ops = concatMap U.flattenExpandedOp (U.contractCode contract)+  ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP]++printAndParse :: FilePath -> U.Contract -> IO U.Contract+printAndParse fp contract1 =+  case parseExpandContract (MSFile fp) (toText $ printUntypedContract True contract1) of+    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
+ morley-test/Test/Serialization/Aeson.hs view
@@ -0,0 +1,53 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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)+  ]
+ morley-test/Test/Serialization/Typed/Michelson.hs view
@@ -0,0 +1,458 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE OverloadedLists #-}++module Test.Serialization.Typed.Michelson+  ( spec_Serialization+  ) where++import qualified Data.Aeson 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(..), unsafeParseAddress)+import Morley.Tezos.Core (Mutez, Timestamp, parseChainId, timestampFromSeconds, toMutez)+import Morley.Tezos.Crypto+  (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash(..), parseKeyHash, parsePublicKey, parseSignature)+import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Test.Cleveland.Instances ()+import Test.Cleveland.Util+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"   $ toMutez 0   ~: "050000"   ~: [aesonQQ| { "int": "0" } |]+    , Example "1"   $ toMutez 1   ~: "050001"   ~: [aesonQQ| { "int": "1" } |]+    , Example "63"  $ toMutez 63  ~: "05003f"   ~: [aesonQQ| { "int": "63" } |]+    , Example "64"  $ toMutez 64  ~: "05008001" ~: [aesonQQ| { "int": "64" } |]+    , Example "65"  $ toMutez 65  ~: "05008101" ~: [aesonQQ| { "int": "65" } |]+    , Example "127" $ toMutez 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127" } |]+    , Example "128" $ toMutez 128 ~: "05008002" ~: [aesonQQ| { "int": "128" } |]+    , Example "129" $ toMutez 129 ~: "05008102" ~: [aesonQQ| { "int": "129" } |]+    , Example "191" $ toMutez 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191" } |]+    , Example "192" $ toMutez 192 ~: "05008003" ~: [aesonQQ| { "int": "192" } |]+    , Example "193" $ toMutez 193 ~: "05008103" ~: [aesonQQ| { "int": "193" } |]+    ]++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" $+        leftToShowPanic (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 unsafeParseAddress++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 = ( leftToShowPanic $ parsePublicKey keyStr, (keyBytes, json) )++chainIdTest :: Spec+chainIdTest =+  serializeSpecManual VChainId "chain_id" allTestMethods $ examples+    [ leftToShowPanic+          (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 = (leftToShowPanic $ 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 unsafeParseAddress+    parseEpAddrs = map $ first unsafeParseEpAddress++    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 = unsafeParseAddress "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"+    ]
+ morley-test/Test/Serialization/Untyped/Michelson.hs view
@@ -0,0 +1,2882 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE OverloadedLists #-}++module Test.Serialization.Untyped.Michelson+  ( spec_Serialization+  ) where++import Prelude hiding (Ordering(..))++import qualified Data.Aeson 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 qualified Morley.Michelson.Parser as Parser+import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped 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 = unsafeFromHex (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 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 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 = unsafeFromHex (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 = unsafeFromHex "050a0000000400000000"+        badEncodedGt  = unsafeFromHex "050a0000000500000000"+        badEncodedLt  = unsafeFromHex "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" }+            ]+         |]+    ]
+ morley-test/Test/Serialization/Util.hs view
@@ -0,0 +1,119 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE OverloadedLists #-}+++module Test.Serialization.Util+  ( Example(..)+  , TestMethod(..)+  , deserializeNegSpecImpl+  , examples+  , fromBinaryTestMethodImpl+  , fromJsonTestMethodImpl+  , serializeSpecManualImpl+  , toBinaryTestMethodImpl+  , toJsonTestMethodImpl+  , (~:)+  ) where++import qualified Data.Aeson 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 (unsafeFromHex 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 = unsafeFromHex (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
+ morley-test/Test/Tezos/Address.hs view
@@ -0,0 +1,102 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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+  (Address, formatAddress, parseAddress, parseAddressRaw, ta, unsafeParseAddress,+  unsafeParseAddressRaw)+import Test.Cleveland.Util (fromHex, unsafeFromHex)++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 (parseAddressRaw . unsafeFromHex $ b) `shouldSatisfy` isRight)+  , testCase "Parsed addresses are equivalent in canonical and raw byte form" $+    forM_ sampleAddresses (\(a, b) -> (STB . unsafeParseAddressRaw . unsafeFromHex $ b) @?= (STB . unsafeParseAddress $ a))+  , 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 (unsafeParseAddressRaw (unsafeFromHex b)) @?= a) | (a, b) <- sampleAddresses ]+  , [ testCase ("Fails to parse invalid address " <> toString a)+      (parseInvalidAddresses a `shouldSatisfy` isNothing) | a <- invalidRawAddresses ]+  ]+  where+    parseInvalidAddresses :: Text -> Maybe Address+    parseInvalidAddresses a = do+      bs <- fromHex a+      rightToMaybe (parseAddressRaw bs)++unit_ta :: Assertion+unit_ta = do+  [ta|tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU|]+    @?= unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"+  [ta|tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd|]+    @?= unsafeParseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd"+  [ta|KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45|]+    @?= unsafeParseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45"+  [ta|KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh|]+    @?= unsafeParseAddress "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"+  ]
+ morley-test/Test/Tezos/Core.hs view
@@ -0,0 +1,81 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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+      ]
+ morley-test/Test/Tezos/Crypto.hs view
@@ -0,0 +1,394 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 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, partialParse, unsafeFromHex)+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 = partialParse parsePublicKey (sdPublicKey sd)+    signature = partialParse parseSignature (sdSignature sd)++checkRawSignatureSample :: SignatureData -> Assertion+checkRawSignatureSample sd =+  checkSignature publicKey signature (sdBytes sd) @?= sdValid sd+  where+    publicKey = partialParse parsePublicKeyRaw (unsafeFromHex $ sdPublicKey sd)+    signature = partialParse parseSignatureRaw (unsafeFromHex $ sdSignature sd)++----------------------------------------------------------------------------+-- 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 = partialParse parsePublicKey pkText+    keyHash = partialParse 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 . unsafeFromHex $ b) `shouldSatisfy` isRight)+  , testCase "Parsed signatures are equivalent in canonical and raw byte form" $+    forM_ samplePairSignatures (\(a, b) ->+      (STB . (partialParse parseSignatureRaw) . unsafeFromHex $ b)+        @?= (STB . (partialParse parseSignature) $ a))+  , testGroup "Fails to parse invalid signatures:"+      [ testCase (toString a)+          (parseInvalidSignature a `shouldSatisfy` isNothing) | a <- invalidRawSignatures+      ]+  ]++  where+    parseInvalidSignature :: Text -> Maybe Signature+    parseInvalidSignature a = do+      bs <- fromHex a+      rightToMaybe (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 . unsafeFromHex $ b) `shouldSatisfy` isRight)+  , testCase "Parsed public keys are equivalent in canonical and raw byte form" $+    forM_ sampleRawPublicKeys (\(a, b) -> (STB . (partialParse parsePublicKeyRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parsePublicKey) $ a))+  , testGroup "Fails to parse invalid public keys:"+      [ testCase (toString a)+          (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawPublicKeys+      ]+  ]++  where+    parseInvalidKey :: Text -> Maybe PublicKey+    parseInvalidKey a = do+      bs <- fromHex a+      rightToMaybe (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 . unsafeFromHex $ b) `shouldSatisfy` isRight)+  , testCase "Parsed key hashes are equivalent in canonical and raw byte form" $+    forM_ sampleRawKeyHashes (\(a, b) -> (STB . (partialParse parseKeyHashRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parseKeyHash) $ a))+  , testGroup "Fails to parse invalid key hashes:"+      [ testCase (toString a)+          (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawKeyHashes+      ]+  ]+  where+    parseInvalidKey :: Text -> Maybe KeyHash+    parseInvalidKey a = do+      bs <- fromHex a+      rightToMaybe (parseKeyHashRaw bs)++    sampleRawKeyHashes :: [(Text, Text)]+    sampleRawKeyHashes =+      [ ("tz1NaZzLvdDBLfV2LWC6F4SJfNV2jHdZJXkJ"+        ,"002040d6c2ede06fbd1cbc16d51c3085dc2e43e396")+      , ("tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw"+        ,"0092629ed0afa9cd42835ce09ee2623c1efa0b590d")+      , ("tz2EfqCbLmpfv7mNiLcMmhxAwdgHtPTcwR4W"+        ,"0145b5e7d31bf6612e61ebfa7a6d929ce7800a55a4")+      , ("tz2Darj3LyQzekU98ZK8diHvuyn1YYjcHpc6"+        ,"0139ccf913874519b2d20917bf5f2de537420d2726")+      ]++    invalidRawKeyHashes :: [Text]+    invalidRawKeyHashes =+      [ ""+      , "15002040d6c2ede06fbd1cbc16d51c3085dc2e43e396"+      , "100000015002040d6c2ede06fbd1cbc16d51c3085dc2e43e396"+      , "1100000015002040d6c2ede06fbd1cbc16d51c3085dc2e43e396"+      ]
+ morley-test/Test/Tezos/Crypto/BLS12381.hs view
@@ -0,0 +1,224 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for 'Morley.Tezos.Crypto.BLS12381'.+--+-- Tezos has some Python tests that we make use of in our module:+-- <https://gitlab.com/metastatedev/tezos/-/commit/f10c39e0030e6b4fdd416a62de7b80b6ffdfeacf>.+module Test.Tezos.Crypto.BLS12381+  ( test_SerializationRoundtrip+  , test_SerializationTrivialCases+  , test_SerializationEdgeCases+  , test_PairingCheck+  ) where++import Prelude hiding (negate)++import qualified Data.ByteString as BS+import Hedgehog (Gen, assert, forAll, property, withTests, (===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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 hiding (fromHex)++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+        unsafeFromMichelsonBytes frZeroValue++    , testCase "G1" $+        zero @Bls12381G1 @?=+        unsafeFromMichelsonBytes g1ZeroValue++    , testCase "G2" $+        zero @Bls12381G2 @?=+        unsafeFromMichelsonBytes g2ZeroValue++    ]++  , testGroup "One"+    [ testCase "Fr" $+        (1 :: Bls12381Fr) @?=+        unsafeFromMichelsonBytes frOneValue++    , testCase "G1" $+        g1One @?=+        unsafeFromMichelsonBytes g1OneValue++    , testCase "G2" $+        g2One @?=+        unsafeFromMichelsonBytes g2OneValue++    ]++  , testGroup "Negate one"+    [ testCase "Fr" $+        negate (1 :: Bls12381Fr) @?=+        unsafeFromMichelsonBytes frMinusOneValue++    , testCase "G1" $+        negate g1One @?=+        unsafeFromMichelsonBytes g1MinusOneValue++    , testCase "G2" $+        negate g2One @?=+        unsafeFromMichelsonBytes g2MinusOneValue++    ]++  ]++test_SerializationEdgeCases :: [TestTree]+test_SerializationEdgeCases =+  [ testGroup "Fr"+    [ testCase "Smaller length" $+        fromMichelsonBytes @Bls12381Fr (unsafeFromHex "0100")+        @?= Right 1++    , testCase "Larger length" $+        fromMichelsonBytes @Bls12381Fr (unsafeFromHex $ 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 = unsafeFromHex "01000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73"++-- Constants (taken from Tezos tests mentioned at the top)+----------------------------------------------------------------------------++g1SomeVal :: ByteString+g1SomeVal = unsafeFromHex "026fcea34d1a4c5125142dfa3b616086309cab49e60e548d95de658af4d9329c269dc132bd5d884617e8767600daeee90c6f5d25f3d63540f3b799d291e5df4a90244346ed780d5c9d3afa8f3c9a196e089fa4edc4a9806592e8561d626579e3"++g2SomeVal :: ByteString+g2SomeVal = unsafeFromHex "14e9b22683a66543ec447b7aa76e4404424709728507581d0b3f60a8062c3f7c7d3365197c59f7c961fa9731084f5be60d0a936e93d556bdef2032cdcae2fa9902dcbe105e01d7ab7126d83486d882c4efd2fc1ac55044157333be19acf0cb7a10bc41c8081c9babd8d5b41b645badd4a679b3d4e1b3ea2c0e1f53b39c00b3889a40306c9b9ee2da5831e90148334d91016474d07e0f4e36d2d51b5ca11b633b9a940b9c126aebf4a2537c18fdc6967fb677824bfa902157e53cb499a021e57b"++frZeroValue :: ByteString+frZeroValue = unsafeFromHex "0000000000000000000000000000000000000000000000000000000000000000"++g1ZeroValue :: ByteString+g1ZeroValue = unsafeFromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"++g2ZeroValue :: ByteString+g2ZeroValue = unsafeFromHex "400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"++frOneValue :: ByteString+frOneValue = unsafeFromHex "0100000000000000000000000000000000000000000000000000000000000000"++g1OneValue :: ByteString+g1OneValue = unsafeFromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb08b3f481e3aaa0f1a09e30ed741d8ae4fcf5e095d5d00af600db18cb2c04b3edd03cc744a2888ae40caa232946c5e7e1"++g2OneValue :: ByteString+g2OneValue = unsafeFromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb80606c4a02ea734cc32acd2b02bc28b99cb3e287e85a763af267492ab572e99ab3f370d275cec1da1aaa9075ff05f79be0ce5d527727d6e118cc9cdc6da2e351aadfd9baa8cbdd3a76d429a695160d12c923ac9cc3baca289e193548608b82801"++frMinusOneValue :: ByteString+frMinusOneValue = unsafeFromHex "00000000fffffffffe5bfeff02a4bd5305d8a10908d83933487d9d2953a7ed73"++g1MinusOneValue :: ByteString+g1MinusOneValue = unsafeFromHex "17f1d3a73197d7942695638c4fa9ac0fc3688c4f9774b905a14e3a3f171bac586c55e83ff97a1aeffb3af00adb22c6bb114d1d6855d545a8aa7d76c8cf2e21f267816aef1db507c96655b9d5caac42364e6f38ba0ecb751bad54dcd6b939c2ca"++g2MinusOneValue :: ByteString+g2MinusOneValue = unsafeFromHex "13e02b6052719f607dacd3a088274f65596bd0d09920b61ab5da61bbdc7f5049334cf11213945d57e5ac7d055d042b7e024aa2b2f08f0a91260805272dc51051c6e47ad4fa403b02b4510b647ae3d1770bac0326a805bbefd48056c8c121bdb813fa4d4a0ad8b1ce186ed5061789213d993923066dddaf1040bc3ff59f825c78df74f2d75467e25e0f55f8a00fa030ed0d1b3cc2c7027888be51d9ef691d77bcb679afda66c73f17f9ee3837a55024f78c71363275a75d75d86bab79f74782aa"
+ morley-test/Test/Tezos/Crypto/Hash.hs view
@@ -0,0 +1,62 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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
+ morley-test/Test/Tezos/Crypto/Timelock.hs view
@@ -0,0 +1,52 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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+  ]
+ morley-test/Test/Typeable.hs view
@@ -0,0 +1,35 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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+    ]+  ]
+ morley-test/Test/Typecheck.hs view
@@ -0,0 +1,364 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 qualified Data.Map as M+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Typeable (typeRep)+import Fmt (build, pretty)+import Hedgehog (Gen, Property, evalNF, forAll, property, (===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import 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 (prepareContract)+import Morley.Michelson.Text (MText)+import Morley.Michelson.TypeCheck+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Untyped (ParameterType(..), noAnn, unsafeBuildEpName)+import qualified Morley.Michelson.Untyped as Un+import Morley.Tezos.Address (Address(..), mkContractHashHack)+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)+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 <- prepareContract (Just file)+  case typeCheckingWith options $ typeCheckContract c of+    Left err+      | wellTyped ->+        expectationFailure $+        "Typechecker unexpectedly failed on " <> show file <>+        ": " <> displayException err+      | otherwise -> onError err+    Right _+      | not wellTyped ->+        assertFailure $+        "Typechecker unexpectedly considered " <> show 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 T.TUnit T.TKey)+      @?= "Types not equal: unit /= key"++  , testCase "StackEqError" $+      build (StackEqError [T.TUnit, T.TBytes] [])+      @?= "Stacks not equal: [unit, bytes] /= []"++  , 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: " <> show other+    , testCase "Nested seq with the same levels of nesting can be typechecked as list" $+        case runTC $ typeCheckValue @('T.TList ('T.TList 'T.TInt)) wellTypedList of+          Right _  -> pass+          Left err -> assertFailure $ "Unexpected error: " <> show err+    , testCase "Nested seq with different levels of nesting can be typechecked as lambda" $+        case runTC $ typeCheckValue @('T.TLambda 'T.TInt 'T.TInt) wellTypedLambda of+          Right _  -> pass+          Left err -> assertFailure $ "Unexpected error: " <> show err+    ]++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: " <> show res++  , testCase "Entrypoint does not exist" $+      case typeCheckingWith def $+             typeVerifyParameter @('T.TContract 'T.TKey) env1 addrUVal1+      of+        Left (TCFailedOnValue _ _ _ _ (Just (EntrypointNotFound _))) -> pass+        res -> assertFailure $ "Unexpected result: " <> show res++  , testCase "Correct contract value" $+      case typeCheckingWith def $+             typeVerifyParameter @('T.TContract 'T.TInt) env1 addrUVal2+      of+        Right _ -> pass+        res -> assertFailure $ "Unexpected result: " <> show res+  ]+  where+    addr1' = mkContractHashHack "123"+    addr1 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "a")+    addr2 = T.EpAddress (ContractAddress addr1') (unsafeBuildEpName "q")+    addrUVal1 = Un.ValueString $ T.mformatEpAddress addr1+    addrUVal2 = Un.ValueString $ T.mformatEpAddress addr2++    env1 = M.fromList+      [ ( addr1', unsafeMkSomeParamType $ ParameterType [utypeQ| ( nat %s | int %q ) |] noAnn)+      ]++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++  ]
+ morley-test/Test/Typecheck/Annotation.hs view
@@ -0,0 +1,107 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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.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"+          p1 = "p1"+          name = "name"+      contract <-+        importContract @('TPair ('TPair 'TUnit 'TString) 'TBool) @'TUnit file+      stripVarAnn (cCode contract) @?=+          loc 2 7 (withNotes (NTPair noAnn p1 noAnn noAnn noAnn (NTPair noAnn noAnn no_name noAnn noAnn starNotes starNotes) starNotes) (AnnCAR param noAnn))+          `Seq` Nested (+            withNotes (NTPair noAnn noAnn no_name noAnn noAnn starNotes starNotes) (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
+ morley-test/Test/Untyped/Instr.hs view
@@ -0,0 +1,47 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)+      ]
+ morley-test/Test/Util/HUnit.hs view
@@ -0,0 +1,18 @@+-- 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)
+ morley-test/Test/Util/Hedgehog.hs view
@@ -0,0 +1,91 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-+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 Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Aeson as Aeson+import Fmt (Buildable, pretty)+import Hedgehog (Gen)+import Test.Tasty (TestTree)+import qualified Text.Show (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 = 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
+ morley-test/Test/Util/Parser.hs view
@@ -0,0 +1,28 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 qualified Morley.Michelson.Parser 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`
+ morley-test/Test/ValConversion.hs view
@@ -0,0 +1,75 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Testing of toVal / fromVal conversions++module Test.ValConversion+  ( test_Roundtrip+  , unit_toVal+  ) where++import Hedgehog (Gen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range 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"
+ morley-test/Test/Views.hs view
@@ -0,0 +1,80 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on views-related primitives.+module Test.Views+  ( test_ViewsSets+  ) where++import Fmt (pretty)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++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 = unsafeMkViewName 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 (unsafeMkViewName "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 (unsafeMkViewName "a"))++    ]++  , testGroup "Lookup"+    let viewsSet1 = either (error . pretty) id $ mkViewsSet+          [ dummySomeView "" 0+          , dummySomeView "a" 1+          ]+    in+    [ testCase "Can find a present view" $ do+        lookupView (unsafeMkViewName "") viewsSet1+          @?= Just (dummySomeView "" 0)+        lookupView (unsafeMkViewName "a") viewsSet1+          @?= Just (dummySomeView "a" 1)++    , testCase "Fail to find a non-existent view" $+        lookupView (unsafeMkViewName "x") viewsSet1+          @?= Nothing++    ]++  ]
+ morley-test/Tree.hs view
@@ -0,0 +1,5 @@+-- 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 #-}
+ src/Hedgehog/Gen/Michelson.hs view
@@ -0,0 +1,43 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Michelson+  ( genInstrCallStack+  , genLetName+  , genSrcPos+  , genPos+  , genMText+  ) where+++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..))+import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, unsafeMkMText)++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)+      ]++genLetName :: MonadGen m => m LetName+genLetName = LetName <$> Gen.text (Range.linear 0 3) Gen.unicodeAll++genSrcPos :: MonadGen m => m SrcPos+genSrcPos = SrcPos <$> genPos <*> genPos++genPos :: MonadGen m => m Pos+genPos = Pos <$> Gen.word Range.linearBounded++genMText :: MonadGen m => m MText+genMText =+  unsafeMkMText <$> Gen.text+    (Range.linear 0 100)+    (Gen.enum (toEnum @Char minBoundMChar) (toEnum @Char maxBoundMChar))
+ src/Hedgehog/Gen/Michelson/Typed.hs view
@@ -0,0 +1,185 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Hedgehog.Gen.Michelson.Typed+  ( genBigMap+  , genEpAddress+  , genValueKeyHash+  , genValueMutez+  , genValueInt+  , genValueList+  , genValueUnit+  , genValuePair+  , genValueTimestamp+  , genValueChestAndKey++  , genValue+  , genValue'++  , genSimpleInstr+  ) where++import qualified Control.Exception as Ex+import Data.Singletons (Sing)+import Hedgehog (GenBase, MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Gen.Michelson.Untyped (genEpName)+import Hedgehog.Gen.Tezos.Address (genAddress)+import Hedgehog.Gen.Tezos.Core (genChainId, genMutez, genTimestamp)+import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSignature)+import Hedgehog.Gen.Tezos.Crypto.BLS12381 (genBls12381Fr, genBls12381G1, genBls12381G2)+import Morley.Michelson.Text (unsafeMkMText)+import Morley.Michelson.Typed+  (Comparable, Instr(DROP, FAILWITH, PUSH, SWAP, Seq, UNIT), SingT(..), T(..), Value'(..),+  WellTyped, toVal)+import Morley.Michelson.Typed.Entrypoints (EpAddress(..), unsafeSepcCallRoot)+import Morley.Michelson.Typed.Haskell.Value (BigMap(..), BigMapId(..), ToT, WellTypedToT)+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.Value (RemFail(..))+import qualified Morley.Tezos.Crypto.BLS12381 as BLS++import Hedgehog.Gen.Tezos.Crypto.Timelock (genChestAndKey)++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 =+  BigMap+    <$> Gen.maybe (fmap BigMapId genBigMapId)+    <*> Gen.map (Range.linear 0 100) (liftA2 (,) genK genV)++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++genValueInt :: MonadGen m => m (Value' instr 'TInt)+genValueInt = VInt <$> Gen.integral (Range.linearFrom 0 -1000 1000)++genValueList :: (MonadGen m, SingI a) => m (Value' instr a) -> m (Value' instr ('TList a))+genValueList genA = VList <$> Gen.list (Range.linear 0 100) 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 genA genB = VPair ... (,) <$> genA <*> genB++genValueTimestamp :: MonadGen m => m (Value' instr 'TTimestamp)+genValueTimestamp = VTimestamp <$> genTimestamp++genValueChestAndKey :: MonadGen m => m (Value' instr 'TChest, Value' instr 'TChestKey)+genValueChestAndKey = bimap VChest VChestKey <$> genChestAndKey++genValue+  :: forall t m.+      (MonadGen m, GenBase m ~ Identity, HasNoOp t, WellTyped t)+  => m (Value' Instr t)+genValue = genValue' (sing @t)++-- | Generate a simple instruction.+-- Ideally instruction generator should produce instructions containing+-- all possible primitive instructions.+-- In our case we consider only a few primitive instructions and+-- pick one from a hardcoded list. Hence we call it "simple".+-- Another limitation is that input stack and output stack types must be+-- identical and non-empty.+genSimpleInstr :: (MonadGen m, inp ~ (x ': xs), SingI x) => m (Instr inp inp)+genSimpleInstr = Gen.element+  [ UNIT `Seq` FAILWITH+  , PUSH (VInt 5) `Seq` DROP+  , UNIT `Seq` SWAP `Seq` SWAP `Seq` DROP+  ]++genBigMapId :: MonadGen m => m Natural+genBigMapId = Gen.integral (Range.constant 0 100000000)++genValue'+  :: (MonadGen m, GenBase m ~ Identity, HasNoOp t, WellTyped t)+  => Sing t -> m (Value' Instr t)+genValue' = \case+  STKey -> VKey <$> genPublicKey+  STUnit -> genValueUnit+  STSignature -> VSignature <$> genSignature+  STChainId -> VChainId <$> genChainId+  STOption st -> Gen.choice+    [ pure $ VOption Nothing+    , 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)+  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)+  STPair STChestKey STChest -> VPair . bimap VChestKey VChest . swap <$> genChestAndKey+  STPair l r -> VPair <$> ((,) <$> genNoOpValue l <*> genNoOpValue r)+  STOr l r -> VOr <$> Gen.choice+    [ Left <$> genNoOpValue l+    , Right <$> genNoOpValue r+    ]+  -- 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 . unsafeMkMText . fromString <$> Gen.string (Range.linear 0 100) Gen.alphaNum+  STBytes -> VBytes <$> Gen.bytes (Range.linear 0 100)+  STMutez -> genValueMutez+  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+  STAddress -> VAddress <$> genEpAddress+  STBool -> VBool <$> Gen.bool+  STChest -> VChest . fst <$> genChestAndKey+  STChestKey -> VChestKey . snd <$> genChestAndKey+  STNever -> Gen.discard+  where+    genNoOpValue+      :: (MonadGen m, GenBase m ~ Identity, WellTyped t')+      => Sing t' -> m (Value' Instr t')+    genNoOpValue st = case checkOpPresence st of+      OpAbsent -> genValue' st+      _ -> Gen.discard++    genBls12Pairing+      :: MonadGen m+      => m (Value' Instr ('TList $ 'TPair 'TBls12381G1 'TBls12381G2))+    genBls12Pairing = Gen.frequency+      [ -- random pairing (likely incorrect one)+        ( 1+        , fmap toVal $ Gen.list (Range.linear 0 10) $+            (,) <$> genBls12381G1 <*> genBls12381G2+        )+      , -- correct pairing case+        ( 1+        , do+            g1 <- genBls12381G1+            g2 <- genBls12381G2+            let pairing = [(g1, g2), (g1, BLS.negate g2)]+            Ex.assert (BLS.checkPairing pairing) $+              return (toVal pairing)+        )+      ]
+ src/Hedgehog/Gen/Michelson/Untyped.hs view
@@ -0,0 +1,357 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Michelson.Untyped+  ( genInternalByteString+  , genVar+  , genTyVar+  , genExpandedOp+  , genExtInstrAbstract+  , genPrintComment+  , genStackRef+  , genTestAssert+  , genStackFn+  , genStackTypePattern+  , genInstrAbstract+  , genContract+  , genContract'+  , genEntriesOrder+  , genValue+  , genValue'+  , genElt+  , genParameterType+  , genType+  , genValidType+  , genEpName+  , genAnnotation+  , genT+  ) where++import Prelude hiding (EQ, GT, LT)++import qualified Data.Text as T+import Hedgehog (MonadGen(GenBase), Range)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Michelson.Untyped++import Hedgehog.Gen.Michelson (genInstrCallStack, genMText)++genInternalByteString :: MonadGen m => m InternalByteString+genInternalByteString = InternalByteString <$> Gen.bytes (Range.linear 0 100)++genVar :: MonadGen m => m Var+genVar = Var <$> genSmallText++genTyVar :: (MonadGen m, GenBase m ~ Identity) => m TyVar+genTyVar = Gen.choice [VarID <$> genVar, TyCon <$> genValidType]++genExpandedOp :: (MonadGen m, GenBase m ~ Identity) => m ExpandedOp+genExpandedOp = Gen.recursive Gen.choice+  -- non-recursive constructors+  [+    -- NB: When used together, genExpandedOp & genInstrAbstract are mutually recursive.+    -- So we use a generator of InstrAbstract that does not contain any ops as an escape hatch.+    PrimEx <$> Gen.choice instrAbstractWithoutOp+  ]+  -- recursive constructors+  [ PrimEx <$> genInstrAbstract genExpandedOp+  , SeqEx <$> genSmallList genExpandedOp+  , Gen.subtermM genExpandedOp $ \expandedOp -> WithSrcEx <$> genInstrCallStack <*> pure expandedOp+  ]++genExtInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (ExtInstrAbstract op)+genExtInstrAbstract genOp = Gen.choice+  [ STACKTYPE <$> genStackTypePattern+  , FN <$> genSmallText <*> genStackFn <*> genSmallList genOp+  , UTEST_ASSERT <$> genTestAssert genOp+  , UPRINT <$> genPrintComment+  , UCOMMENT <$> genSmallText+  ]++genPrintComment :: MonadGen m => m PrintComment+genPrintComment = PrintComment <$> Gen.list (Range.linear 0 5) (Gen.either genSmallText genStackRef)++genStackRef :: MonadGen m => m StackRef+genStackRef = StackRef <$> Gen.integral (Range.linear 0 (fromIntegral $ maxBound @Word64))++genTestAssert :: MonadGen m => m op -> m (TestAssert op)+genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment <*> genSmallList genOp++genStackFn :: (MonadGen m, GenBase m ~ Identity) => m StackFn+genStackFn = StackFn+  <$> Gen.maybe (Gen.set smallCollectionRange genVar)+  <*> genStackTypePattern+  <*> genStackTypePattern++genStackTypePattern :: (MonadGen m, GenBase m ~ Identity) => m StackTypePattern+genStackTypePattern = Gen.recursive Gen.choice+  [ pure StkEmpty, pure StkRest ]+  [ Gen.subtermM genStackTypePattern $ \stp -> StkCons <$> genTyVar <*> pure stp ]++genInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (InstrAbstract op)+genInstrAbstract genOp =+  Gen.choice $ instrAbstractWithOp genOp <> instrAbstractWithoutOp++instrAbstractWithOp :: (MonadGen m, GenBase m ~ Identity) => m op -> [m (InstrAbstract op)]+instrAbstractWithOp genOp =+  [ EXT <$> genExtInstrAbstract genOp+  , PUSH <$> genAnnotation <*> genValidType <*> genValue' genOp+  , IF_NONE <$> genSmallList genOp <*> genSmallList genOp+  , IF_LEFT <$> genSmallList genOp <*> genSmallList genOp+  , IF_CONS <$> genSmallList genOp <*> genSmallList genOp+  , MAP <$> genAnnotation <*> genSmallList genOp+  , ITER <$> genSmallList genOp+  , IF <$> genSmallList genOp <*> genSmallList genOp+  , LOOP <$> genSmallList genOp+  , LOOP_LEFT <$> genSmallList genOp+  , LAMBDA <$> genAnnotation <*> genValidType <*> genValidType <*> genSmallList genOp+  , DIP <$> genSmallList genOp+  , DIPN <$> Gen.word Range.linearBounded <*> genSmallList genOp+  , CREATE_CONTRACT <$> genAnnotation <*> genAnnotation <*> genContract' genOp+  ]++instrAbstractWithoutOp :: (MonadGen m, GenBase m ~ Identity) => [m (InstrAbstract op)]+instrAbstractWithoutOp =+  [ DROPN <$> Gen.word Range.linearBounded+  , pure DROP+  , DUP <$> genAnnotation+  , DUPN <$> genAnnotation <*> Gen.word Range.linearBounded+  , pure SWAP+  , DIG <$> Gen.word Range.linearBounded+  , DUG <$> Gen.word Range.linearBounded+  , SOME <$> genAnnotation <*> genAnnotation+  , NONE <$> genAnnotation <*> genAnnotation <*> genValidType+  , 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+  , CONS <$> genAnnotation+  , SIZE <$> genAnnotation+  , EMPTY_SET <$> genAnnotation <*> genAnnotation <*> genValidType+  , EMPTY_MAP <$> genAnnotation <*> genAnnotation <*> genValidType <*> genValidType+  , EMPTY_BIG_MAP <$> genAnnotation <*> genAnnotation <*> genValidType <*> genValidType+  , MEM <$> genAnnotation+  , GET <$> genAnnotation+  , GETN <$> genAnnotation <*> Gen.word Range.linearBounded+  , UPDATE <$> genAnnotation+  , EXEC <$> genAnnotation+  , APPLY <$> genAnnotation+  , pure FAILWITH+  , CAST <$> genAnnotation <*> genValidType+  , RENAME <$> genAnnotation+  , PACK <$> genAnnotation+  , UNPACK <$> genAnnotation <*> genAnnotation <*> genValidType+  , CONCAT <$> genAnnotation+  , SLICE <$> genAnnotation+  , ISNAT <$> genAnnotation+  , ADD <$> genAnnotation+  , SUB <$> genAnnotation+  , MUL <$> genAnnotation+  , EDIV <$> genAnnotation+  , ABS <$> genAnnotation+  , NEG <$> genAnnotation+  , LSL <$> genAnnotation+  , LSR <$> genAnnotation+  , OR <$> genAnnotation+  , AND <$> genAnnotation+  , XOR <$> genAnnotation+  , NOT <$> genAnnotation+  , COMPARE <$> genAnnotation+  , EQ <$> genAnnotation+  , NEQ <$> genAnnotation+  , LT <$> genAnnotation+  , GT <$> genAnnotation+  , LE <$> genAnnotation+  , GE <$> genAnnotation+  , INT <$> genAnnotation+  , SELF <$> genAnnotation <*> genAnnotation+  , CONTRACT <$> genAnnotation <*> genAnnotation <*> genValidType+  , TRANSFER_TOKENS <$> genAnnotation+  , SET_DELEGATE <$> genAnnotation+  , IMPLICIT_ACCOUNT <$> genAnnotation+  , NOW <$> genAnnotation+  , AMOUNT <$> genAnnotation+  , BALANCE <$> genAnnotation+  , CHECK_SIGNATURE <$> genAnnotation+  , SHA256 <$> genAnnotation+  , SHA512 <$> genAnnotation+  , BLAKE2B <$> genAnnotation+  , SHA3 <$> genAnnotation+  , KECCAK <$> genAnnotation+  , HASH_KEY <$> genAnnotation+  , SOURCE <$> genAnnotation+  , SENDER <$> genAnnotation+  , ADDRESS <$> genAnnotation+  , CHAIN_ID <$> genAnnotation+  , LEVEL <$> genAnnotation+  , SELF_ADDRESS <$> genAnnotation+  ]++genContract :: (MonadGen m, GenBase m ~ Identity) => m Contract+genContract = genContract' genExpandedOp++genContract' :: (MonadGen m, GenBase m ~ Identity) => m op -> m (Contract' op)+genContract' genOp = Contract+  <$> genParameterType True+  <*> genValidType+  <*> genSmallList genOp+  <*> genEntriesOrder+  <*> Gen.list (Range.exponential 0 2) (genSomeView genOp)++genEntriesOrder :: (MonadGen m) => m EntriesOrder+genEntriesOrder = Gen.enumBounded++genViewName :: (MonadGen m, GenBase m ~ Identity) => m ViewName+genViewName = unsafeMkViewName <$> Gen.text+  (Range.linear 0 viewNameMaxLength)+  (Gen.filter isValidViewNameChar Gen.ascii)++genSomeView :: (MonadGen m, GenBase m ~ Identity) => m op -> m (View' op)+genSomeView genOp = View+  <$> genViewName+  <*> genValidType+  <*> genValidType+  <*> genSmallList genOp++genValue :: (MonadGen m, GenBase m ~ Identity) => m Value+genValue = genValue' genExpandedOp++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+  , pure ValueUnit+  , pure ValueTrue+  , pure ValueFalse+  , pure ValueNone+  , pure ValueNil+  ]+  -- recursive constructors+  [ Gen.subterm2 (genValue' genOp) (genValue' genOp) ValuePair+  , Gen.subterm (genValue' genOp) ValueLeft+  , Gen.subterm (genValue' genOp) ValueRight+  , Gen.subterm (genValue' genOp) ValueSome+  , ValueSeq <$> genSmallNonEmpty (genValue' genOp)+  , ValueMap <$> genSmallNonEmpty (genElt genOp)+  , ValueLambda <$> genSmallNonEmpty genOp+  ]++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++-- | Generate a 'Ty' that is guaranteed to be valid.+genValidType :: (MonadGen m, GenBase m ~ Identity) => m Ty+genValidType = genType True++genComparableType :: (MonadGen m, GenBase m ~ Identity) => m Ty+genComparableType = Ty <$> genComparableT <*> genAnnotation++genEpName :: (MonadGen m, GenBase m ~ Identity) => m EpName+genEpName = Gen.mapMaybe (rightToMaybe . epNameFromRefAnn) genAnnotation++genAnnotation :: forall m a. (MonadGen m, GenBase m ~ Identity) => m (Annotation a)+genAnnotation = Gen.mapMaybe (rightToMaybe . mkAnnotation) genAnnotationText+  where+    genAnnotationText :: m Text+    genAnnotationText = Gen.frequency+      [ (1, pure "")+      , (17, T.cons <$> annStart <*> Gen.text (Range.linear 0 100) annBodyChar)+      , (1, pure specialFieldAnn)+      , (1, Gen.element specialVarAnns)+      ]++    annStart :: m Char+    annStart = Gen.choice [ pure '_', Gen.alphaNum ]++    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 =+  Gen.recursive Gen.choice+    -- non-recursive constructors+    [ pure TKey+    , pure TUnit+    , pure TSignature+    , pure TChainId+    , pure TOperation+    , pure TInt+    , pure TNat+    , pure TString+    , pure TBytes+    , pure TMutez+    , pure TBool+    , pure TKeyHash+    , pure TTimestamp+    , pure TAddress+    , pure TChest+    , pure TChestKey+    ]+    -- recursive constructors+    [ 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'+    ]+  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+genComparableT =+  Gen.recursive Gen.choice+    [ pure TInt+    , pure TNat+    , pure TString+    , pure TBytes+    , pure TMutez+    , pure TBool+    , pure TKeyHash+    , pure TTimestamp+    , pure TAddress+    ]+    [ TPair <$> genAnnotation <*> genAnnotation <*> genAnnotation <*> genAnnotation <*> genComparableType <*> genComparableType+    ]++smallCollectionRange :: Range Int+smallCollectionRange = Range.linear 0 3++genSmallList :: MonadGen m => m a -> m [a]+genSmallList = Gen.list smallCollectionRange++genSmallNonEmpty :: MonadGen m => m a -> m (NonEmpty a)+genSmallNonEmpty = Gen.nonEmpty smallCollectionRange++genSmallText :: MonadGen m => m Text+genSmallText = Gen.text (Range.linear 0 10) Gen.unicodeAll
+ src/Hedgehog/Gen/Morley/Micheline.hs view
@@ -0,0 +1,47 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Morley.Micheline+  ( genExpression+  , genExpressionSeq+  , genMichelinePrimAp+  , genExprAnnotation+  ) where++import Hedgehog (MonadGen(GenBase))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Gen.Michelson.Untyped (genAnnotation)+import Morley.Micheline.Expression++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++genExpressionSeq :: forall m. (MonadGen m, GenBase m ~ Identity) => m [Expression]+genExpressionSeq = (Gen.list (Range.linear 0 10) genExpression)++genMichelinePrimAp :: forall m. (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp+genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genExpressionSeq <*> genAnnots+  where+    genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive)++    genAnnots :: m [Annotation]+    genAnnots = Gen.list (Range.linear 0 10) genExprAnnotation++genExprAnnotation :: forall m. (MonadGen m, GenBase m ~ Identity) => m Annotation+genExprAnnotation =  Gen.choice+  [genAnnotationType, genAnnotationVariable, genAnnotationField]+  where+    genAnnotationType = AnnotationType <$> genAnnotation+    genAnnotationVariable = AnnotationVariable <$> genAnnotation+    genAnnotationField = AnnotationField <$> genAnnotation
+ src/Hedgehog/Gen/Tezos/Address.hs view
@@ -0,0 +1,27 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Address in Tezos.++module Hedgehog.Gen.Tezos.Address+  ( genAddress+  , genContractAddress+  , genKeyAddress+  ) where++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Gen.Tezos.Crypto (genKeyHash)+import Morley.Tezos.Address (Address(..), ContractHash(..))++genAddress :: MonadGen m => m Address+genAddress = Gen.choice [genKeyAddress, genContractAddress]++genKeyAddress :: MonadGen m => m Address+genKeyAddress = KeyAddress <$> genKeyHash++genContractAddress :: MonadGen m => m Address+genContractAddress = ContractAddress . ContractHash <$> Gen.bytes (Range.singleton 20)
+ src/Hedgehog/Gen/Tezos/Core.hs view
@@ -0,0 +1,72 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++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 qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Core+  (ChainId(..), Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime,+  timestampToSeconds, unsafeMkMutez)++import Test.Cleveland.Instances ()++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++-- | Generates an arbitrary `Mutez` value constrained to the given range.+genMutez' :: MonadGen m => Range Mutez -> m Mutez+genMutez' range = unsafeMkMutez <$> Gen.word64 (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++maxSec :: Integer+maxSec = 86399
+ src/Hedgehog/Gen/Tezos/Crypto.hs view
@@ -0,0 +1,47 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto+  ( genPublicKey+  , genSecretKey+  , genSignature+  , genKeyHashTag+  , genKeyHash+  ) where++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Crypto+  (KeyHash, KeyHashTag, PublicKey, SecretKey(..), Signature(..), hashKey, signatureLengthBytes,+  toPublic)++import qualified Hedgehog.Gen.Tezos.Crypto.Ed25519 as Ed25519+import qualified Hedgehog.Gen.Tezos.Crypto.P256 as P256+import qualified Hedgehog.Gen.Tezos.Crypto.Secp256k1 as Secp256k1++genPublicKey :: MonadGen m => m PublicKey+genPublicKey = toPublic <$> genSecretKey++genSecretKey :: MonadGen m => m SecretKey+genSecretKey = Gen.choice+  [ SecretKeyEd25519 <$> Ed25519.genSecretKey+  , SecretKeySecp256k1 <$> Secp256k1.genSecretKey+  , SecretKeyP256 <$> P256.genSecretKey+  ]++genSignature :: MonadGen m => m Signature+genSignature = Gen.choice+  [ SignatureEd25519 <$> Ed25519.genSignature+  , SignatureSecp256k1 <$> Secp256k1.genSignature+  , SignatureP256 <$> P256.genSignature+  , SignatureGeneric <$> Gen.bytes (Range.singleton signatureLengthBytes)+  ]++genKeyHashTag :: MonadGen m => m KeyHashTag+genKeyHashTag = Gen.enumBounded++genKeyHash :: MonadGen m => m KeyHash+genKeyHash = hashKey <$> genPublicKey
+ src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs view
@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto.BLS12381+  ( genBls12381Fr+  , genBls12381G1+  , genBls12381G2+  ) where++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen++import Morley.Tezos.Crypto.BLS12381+import Test.Cleveland.Util++genBls12381Fr :: MonadGen m => m Bls12381Fr+genBls12381Fr = Gen.enumBounded++genBls12381G1 :: MonadGen m => m Bls12381G1+genBls12381G1 = genRandom generate++genBls12381G2 :: MonadGen m => m Bls12381G2+genBls12381G2 = genRandom generate
+ src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs view
@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto.Ed25519+  ( genPublicKey+  , genSecretKey+  , genSignature+  ) where++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Crypto.Ed25519 (PublicKey, SecretKey, Signature, detSecretKey, sign, toPublic)++genPublicKey :: MonadGen m => m PublicKey+genPublicKey = toPublic <$> genSecretKey++genSecretKey :: MonadGen m => m SecretKey+genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32)++genSignature :: MonadGen m => m Signature+genSignature = sign <$> genSecretKey <*> Gen.utf8 (Range.linear 0 100) Gen.unicode
+ src/Hedgehog/Gen/Tezos/Crypto/P256.hs view
@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto.P256+  ( genPublicKey+  , genSecretKey+  , genSignature+  ) where++import Crypto.Random (drgNewSeed, seedFromInteger, withDRG)+import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Crypto.P256+  (PublicKey, SecretKey, Signature, detSecretKey, detSecretKeyDo, sign, toPublic)++genPublicKey :: MonadGen m => m PublicKey+genPublicKey = toPublic <$> genSecretKey++genSecretKey :: MonadGen m => m SecretKey+genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32)++genSignature :: MonadGen m => m Signature+genSignature = do+  seed <- drgNewSeed . seedFromInteger <$> Gen.integral (Range.linearFrom 0 -1000 1000)+  byteToSign <- Gen.word8 Range.linearBounded+  return $ fst $ withDRG seed $ do+    sk <- detSecretKeyDo+    sign sk (one byteToSign)
+ src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs view
@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto.Secp256k1+  ( genPublicKey+  , genSecretKey+  , genSignature+  ) where++import Crypto.Random (drgNewSeed, seedFromInteger, withDRG)+import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Crypto.Secp256k1+  (PublicKey, SecretKey, Signature, detSecretKey, detSecretKeyDo, sign, toPublic)++genPublicKey :: MonadGen m => m PublicKey+genPublicKey = toPublic <$> genSecretKey++genSecretKey :: MonadGen m => m SecretKey+genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32)++genSignature :: MonadGen m => m Signature+genSignature = do+  seed <- drgNewSeed . seedFromInteger <$> Gen.integral (Range.linearFrom 0 -1000 1000)+  byteToSign <- Gen.word8 Range.linearBounded+  return $ fst $ withDRG seed $ do+    sk <- detSecretKeyDo+    sign sk (one byteToSign)
+ src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Tezos.Crypto.Timelock+  ( genChestAndKey+  , genChestAndKeyWithParams+  , genTLTime+  ) where++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Morley.Tezos.Crypto.Timelock++genChestAndKey :: MonadGen m => m (Chest, ChestKey)+genChestAndKey = fst <$> genChestAndKeyWithParams Nothing++genTLTime :: MonadGen m => m TLTime+genTLTime = unsafeMkTLTime <$> Gen.word64 (Range.linear 1000 10000)++genChestAndKeyWithParams+  :: MonadGen m+  => Maybe TLTime+  -> m ((Chest, ChestKey), (ByteString, TLTime))+genChestAndKeyWithParams mbtime = do+  seed <- Gen.enumBounded+  payload <- Gen.bytes (Range.linear 1 1024)+  time <- maybe genTLTime pure mbtime+  let (chest, key) = createChestAndChestKeyFromSeed seed payload time+  pure ((chest, key), (payload, time))
+ src/Test/Cleveland.hs view
@@ -0,0 +1,185 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Michelson contracts testing on a real Tezos network.+--+-- See the [documentation](https://gitlab.com/morley-framework/morley/-/blob/master/code/cleveland/testingEDSL.md)+-- for usage instructions.+module Test.Cleveland+  ( AliasHint+  , ContractHandle (..)+  , OriginateData (..)+  , UntypedOriginateData (..)+  , TransferData (..)+  , Scenario+  , PureM++  -- * Validation+  , TransferFailure++  -- * Real network implementation based on @tezos-client@ and RPC.+  , testScenario+  , testScenarioOnNetwork+  , scenario++  -- * Emulation tests+  , testScenarioOnEmulator+  , scenarioEmulated+  , withInitialNow+  , withInitialLevel+  , collectLogs+  , logsForAddress++  -- * Cleveland actions+  , MonadCleveland+  , MonadOps+  , MonadEmulated+  , ClevelandT+  , EmulatedT+  , withSender+  , withMoneybag+  , runIO+  , resolveAddress+  , refillable+  , newAddress+  , newFreshAddress+  , signBytes+  , signBinary+  , originate+  , originateSimple+  , originateUntyped+  , originateUntypedSimple+  , originateTypedSimple+  , originateLarge+  , originateLargeSimple+  , originateLargeUntyped+  , originateLargeUntypedSimple+  , transfer+  , transferMoney+  , call+  , importUntypedContract+  , importContract+  , noViews+  , comment+  , getBalance+  , getDelegate+  , registerDelegate+  , getMorleyLogs+  , getMorleyLogs_+  , getStorage+  , getFullStorage+  , getSomeStorage+  , getAllBigMapValues+  , getAllBigMapValuesMaybe+  , getBigMapSize+  , getBigMapSizeMaybe+  , getBigMapValueMaybe+  , getBigMapValue+  , getPublicKey+  , getChainId+  , advanceTime+  , advanceLevel+  , advanceToLevel+  , getNow+  , getLevel+  , getApproximateBlockInterval+  , branchout+  , offshoot+  , setVotingPowers+  , getRunMode+  , RunMode (..)+  , whenEmulation+  , inBatch++  -- * Primitives re-exports+  , EntrypointRef (..)+  , VotingPowers+  , mkVotingPowers+  , mkVotingPowersFromMap++  -- * Assertions+  , failure+  , assert+  , (@==)+  , (@/=)+  , (@@==)+  , (@@/=)+  , checkCompares+  , checkComparesWith+  , evalJust+  , evalRight+  , Showing(..)++    -- * Exception handling+  , attempt+  , catchTransferFailure+  , checkTransferFailure+  , expectTransferFailure+  , expectFailedWith+  , expectError+  , expectCustomError+  , expectCustomError_+  , expectCustomErrorNoArg+  , expectNumericError+  , clarifyErrors++  -- ** Exception predicates+  , TransferFailurePredicate+  , shiftOverflow+  , emptyTransaction+  , badParameter+  , gasExhaustion+  , failedWith+  , addressIs+  -- ** @FAILWITH@ errors+  -- | Convert the many error formats available in @morley@ and @lorentz@ to t'Morley.Michelson.Typed.Existential.SomeConstant'.+  , constant+  , lerror+  , customError+  , customError_+  , customErrorNoArg+  , numericError++  -- * Helpers+  , auto+  , pattern DefEpName+  , ep+  , (?-)++  -- * Integration with @hedgehog@+  , testScenarioProps++  -- * Config (reexports)+  , TezosClientEnv(..)+  , Client.MorleyClientEnv+  , Client.MorleyClientEnv'(..)+  , NetworkEnv (..)+  , MorleyLogs++  -- * AsRPC+  , Client.AsRPC+  , Client.deriveRPC+  , Client.deriveRPCWithStrategy+  , Client.deriveManyRPC+  , Client.deriveManyRPCWithStrategy++  -- * Utilities+  , mapEach+  , forEach+  ) where++import Lorentz (EntrypointRef(..), pattern DefEpName)+import qualified Morley.Client as Client+import Morley.Client.TezosClient.Types (TezosClientEnv(..))+import Morley.Michelson.Interpret (MorleyLogs)+import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap)+import Test.Cleveland.Instances ()+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions+import Test.Cleveland.Internal.Client+import Test.Cleveland.Internal.Hedgehog+import Test.Cleveland.Internal.Pure+import Test.Cleveland.Internal.Scenario+import Test.Cleveland.Tasty.Internal+import Test.Cleveland.Util
+ src/Test/Cleveland/Doc.hs view
@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for testing documentations sanity.+--+-- These tests serve to ensure that documentation generation is not broken and+-- that user follows sane documentation structure (e.g. contract should be+-- named, some entities require description, e.t.c).+--+-- This module only re-exports modules "Test.Cleveland.Doc.Michelson" and+-- "Test.Cleveland.Doc.Lorentz"+module Test.Cleveland.Doc+  ( module Test.Cleveland.Doc.Michelson+  , module Test.Cleveland.Doc.Lorentz+  ) where++import Test.Cleveland.Doc.Lorentz+import Test.Cleveland.Doc.Michelson
+ src/Test/Cleveland/Doc/Common.hs view
@@ -0,0 +1,154 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utilities for testing documentations sanity.+--+-- These tests serve to ensure that documentation generation is not broken and+-- that user follows sane documentation structure (e.g. contract should be+-- named, some entities require description, e.t.c).+module Test.Cleveland.Doc.Common+  ( DocTest (..)+  , mkDocTest+  , excludeDocTest+  , excludeDocTests+  , runDocTests+  , expectDocTestFailure++    -- * Utilities+  , allContractLayers+  , allContractDocItems++    -- * Misc+  , buildDocTest+  , buildMarkdownDocTest+  ) where++import qualified Data.List as L+import Fmt (Buildable(..), pretty)+import GHC.Stack (SrcLoc)+import Test.HUnit (Assertion, assertFailure)+import Test.HUnit.Lang (HUnitFailure(..))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import qualified Text.Show++import Morley.Michelson.Doc++----------------------------------------------------------------------------+-- Misc test helpers+----------------------------------------------------------------------------++-- | Like 'buildDoc', but does not require documentation to be finalized.+buildDocTest :: ContainsDoc a => a -> ContractDoc+buildDocTest = buildDocUnfinalized++-- | Like 'buildMarkdownDoc', but does not require documentation to be finalized.+buildMarkdownDocTest :: ContainsDoc a => a -> LText+buildMarkdownDocTest = contractDocToMarkdown . buildDocUnfinalized++----------------------------------------------------------------------------+-- Framework+----------------------------------------------------------------------------++-- | Test case for contract documentation.+data DocTest = DocTest+  { dtDeclLoc :: SrcLoc+    -- ^ Declaration location, used to distinguish different test predicates.+    -- This is primarily used in 'excludeDocTest'.+  , dtDesc :: String+    -- ^ Description of predicate, which you put to 'testCase'.+  , dtSuite :: HasCallStack => ContractDoc -> Assertion+    -- ^ Test itself.+  }++instance Eq DocTest where+  (==) = (==) `on` dtDeclLoc++instance Show DocTest where+  show = pretty++instance Buildable DocTest where+  build DocTest{..} = "Doc test '" <> build dtDesc <> "'"++-- | Construct 'DocTest'.+--+-- Note: you should not declare helpers with this function rather use it+-- directly in every test suite.+mkDocTest+  :: HasCallStack+  => String+  -> (HasCallStack => ContractDoc -> Assertion)+  -> DocTest+mkDocTest dtDesc dtSuite = DocTest{..}+  where+  (_, dtDeclLoc) = case getCallStack callStack of+    [] -> error "Callstacks operate in a weird way, excluding doc tests won't work"+    layer : _ -> layer++-- | Exclude given test suite.+excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]+excludeDocTest toExclude tests =+  case L.partition (== toExclude) tests of+    ([], _) ->+      error $ "Not in the list of doc items: " <> pretty toExclude+    (_ : _ : _, _) ->+      -- This is e.g. possible if someone abused 'mkDocTest' and created a function+      -- which calls it and this function is used to create multiple predicates+      error "Multiple test predicates were considered equal.\n\+            \Either list of tests contains identical test predicates, \+            \or used predicates were constructed incorrectly."+    ([_], notExcluded) ->+      notExcluded++-- | Calling @excludeDocTests tests toExclude@ returns all test suites from+-- @tests@ which are not present in @toExclude@.+excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]+excludeDocTests = foldr excludeDocTest++-- | Finalize test suites.+runDocTests :: (ContainsDoc code, HasCallStack) => [DocTest] -> code -> [TestTree]+runDocTests tests (buildDocTest -> contractDoc) =+  tests <&> \DocTest{..} ->+    testCase dtDesc (dtSuite contractDoc)++-- | Ensure that 'DocTest' check fires on given contract.+-- Used in tests on this module.+expectDocTestFailure :: ContainsDoc code => DocTest -> code -> Assertion+expectDocTestFailure DocTest{..} (buildDocTest -> contractDoc) = do+  passed <- (dtSuite contractDoc $> True) `catch` \HUnitFailure{} -> pure False+  when passed $ assertFailure "Test didn't fail unexpectedly"++----------------------------------------------------------------------------+-- Test predicates+----------------------------------------------------------------------------++-- Utilities+----------------------------------------------------------------------------++-- | Collect all doc groups (created with @DocGroup@ instruction)+-- recursively.+-- The result will contain grouping doc item itself and its subcontents.+allLayers :: DocBlock -> [(SomeDocItem, DocBlock)]+allLayers block = do+  DocSection docElems <- toList block+  DocElem{..} <- toList docElems+  Just (SubDoc sub) <- pure deSub+  (SomeDocItem deItem, sub) : allLayers sub+++-- | Collect all doc groups (created with @DocGroup@ instruction)+-- within a contract recursively.+-- The result will contain grouping doc item itself (unless we are at root)+-- and its subcontents.+allContractLayers :: ContractDoc -> [(Maybe SomeDocItem, DocBlock)]+allContractLayers contract =+  let contents = cdContents contract+  in (Nothing, contents)+   : (first Just <$> allLayers contents)++-- | Collect all doc items (atomic and grouping) recursively.+allContractDocItems :: DocItem d => ContractDoc -> [d]+allContractDocItems contract =+  fold $ allContractLayers contract <&> \(_, block) ->+    maybe [] toList $ lookupDocBlockSection block
+ src/Test/Cleveland/Doc/Lorentz.hs view
@@ -0,0 +1,199 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Testing predicates for documentation of Lorentz contracts.+module Test.Cleveland.Doc.Lorentz+  ( -- * Test predicates+    testLorentzDoc++    -- * Individual test predicates+  , testDeclaresParameter+  , testEachEntrypointIsDescribed+  , testParamBuildingStepsAreFinalized+  , testAllEntrypointsAreCallable+  , testAllErrorsBelongToEntrypoints++    -- ** Re-exports+  , module Test.Cleveland.Doc.Common+  ) where++import Data.Typeable (typeRep)+import Fmt (Buildable(..), blockListF, fmt, nameF, (+||), (||+))+import Test.HUnit (assertBool, assertFailure)++import Lorentz.Entrypoints.Doc+import Lorentz.Errors+import Morley.Michelson.Doc+import Morley.Util.Markdown+import Morley.Util.Text (dquotes)+import Test.Cleveland.Doc.Common+import Test.Cleveland.Doc.Michelson (testDocBasic)++-- | All ways of describing an entrypoint behaviour.+data DocEpDescription+  = DocEpDescription DDescription+  | DocEpReference DEntrypointReference++instance Buildable DocEpDescription where+  build = \case+    DocEpDescription (DDescription txt) ->+      "description: " <> txt+    DocEpReference (DEntrypointReference name (Anchor anchor)) ->+      "reference \"" <> build name <> "\" (" <> build anchor <> ")"++-- | Extract 'DocEpDescription's of a documentation block.+lookupDocEpDescription :: DocBlock -> [DocEpDescription]+lookupDocEpDescription block = mconcat+  [ map DocEpDescription . maybe [] toList $ lookupDocBlockSection block+  , map DocEpReference . maybe [] toList $ lookupDocBlockSection block+  ]++-- | Check that contract documents its parameter.+testDeclaresParameter :: DocTest+testDeclaresParameter =+  mkDocTest "Contract parameter is documented" $+  \contractDoc ->+    assertBool "No doc items describing contract parameter found" $+      any check (allContractLayers contractDoc)+  where+    check (Nothing, _) = False+    check (Just sdi, _) =+      -- Currently the only way to document parameter (mentioning type of each arm)+      -- is using 'entryCase'. This may not suit for small contracts, then+      -- someone needs to invent another way to document parameter and also mention+      -- it below.+      case sdi of+        DEntrypointDocItem _ -> True+        _ -> False++-- | Check that no group contains two 'DDescription' or 'DEntrypointReference'+-- items.+--+-- This is a stricter version of 'Test.Cleveland.Doc.Michelson.testNoAdjacentDescriptions' test.+testNoAdjacentEpDescriptions :: DocTest+testNoAdjacentEpDescriptions =+  mkDocTest "No two 'DDescription' appear under the same group" $+  \contractDoc ->+    forM_ (allContractLayers contractDoc) $ \(_, block) ->+      case lookupDocEpDescription block of+        ds@(_ : _ : _) ->+          assertFailure . fmt $+             nameF "Found multiple adjacent entrypoint descriptions" $+             blockListF $ map (dquotes . build) (toList ds)+        _ -> pass++-- | It's a common issue to forget to describe an entrypoint.+testEachEntrypointIsDescribed :: DocTest+testEachEntrypointIsDescribed =+  mkDocTest "Each entrypoint has 'DDescription'" $+  \contractDoc -> do+    missingDescs :: [Text] <-+      fmap catMaybes . sequence $ allContractLayers contractDoc <&>+        \(mDocItem, block) -> runMaybeT $ do+          DEntrypointDocItem dep <- MaybeT . pure $ mDocItem+          [] <- pure $ lookupDocEpDescription block+          return (depName dep)++    case nonEmpty missingDescs of+      Nothing -> pass+      Just descs ->+        assertFailure . fmt $+          "Descriptions for the following entrypoints are not found: \n" <>+          blockListF descs <>+          "Put e.g. `doc $ DDescription \"text\"` in the entrypoint logic to \+          \fix this."++-- | Check that 'finalizeParamCallingDoc' is applied to the contract as it+-- always should.+testParamBuildingStepsAreFinalized :: DocTest+testParamBuildingStepsAreFinalized =+  mkDocTest "'finalizeParamCallingDoc' is applied" $+  \contractDoc -> do+    forM_ (allContractDocItems contractDoc) $ \DEntrypointArg{..} ->+      unless (areFinalizedParamBuildingSteps epaBuilding) $+        assertFailure+          "Found unfinalized param building steps, \+          \'How to call this entrypoint' section will not be acknowledged of \+          \contract entrypoints coming from field annotations and may be incorrect.\n\+          \Do you pick documentation of the entire 'Contract', not just contract code? \+          \If the latter is necessary, please call 'finalizeParamCallingDoc' manually."++-- | Check that all documented entrypoints are callable.+--+-- Sometimes having such an entrypoint is fine, e.g. when you have an explicit+-- default entrypoint deep in one arm then other arms (entire arms, not+-- individual entrypoints within them) are uncallable unless also assigned a+-- field annotation; for example see [doc for uncallable entrypoints] note.+-- If this is your case, exclude this test suite with 'excludeDocTest'.+-- But such situations are rare.+--+-- More often, this test failure indicates that entrypoints are documented+-- incorrectly, e.g. 'Lorentz.caseT' is used in some place instead of 'entryCase'.+-- Check whether printed building steps are correct.+--+-- NB: another, simplified example of case when disabling this test is+-- justified:+--+-- @+-- data SubParam1 = Do1 | Default+-- data SubParam2 = Do2 | Do3+-- data Param = Arm1 SubParam1 | Arm2 SubParam2+--   -- ^ with entrypoints derived via t'Lorentz.Entrypoints.EpdRecursive'+-- @+--+-- In this case entire @Arm1@ and @Arm2@ are not true entrypoints, only @Default@+-- and @Do{1,2,3}@ are, but @Arm1@ and @Arm2@ will still appear in documentation+-- as entrypoints.+testAllEntrypointsAreCallable :: DocTest+testAllEntrypointsAreCallable =+  mkDocTest "All entrypoints are callable" $+  \contractDoc ->+    forM_ (allContractDocItems contractDoc) $ \DEntrypointArg{..} ->+      forM_ epaBuilding $ \case+        PbsUncallable pbs ->+          assertFailure . fmt $+            "Found an uncallable entrypoint.\n\+            \Dummy parameter building steps for it: " <> blockListF (reverse pbs)+        _ -> pass++-- | Check that no error is thrown outside of entrypoint.+--+-- This is possible e.g. when some check is performed in the beginning of the+-- contract, before an entrypoint is selected and executed.+--+-- All errors (except for internal ones) must belong to some entrypoint for+-- documetation to be constructed sanely. Thus it might be necessary to create+-- a special section common for multiple entrypoints to include that error.+testAllErrorsBelongToEntrypoints :: DocTest+testAllErrorsBelongToEntrypoints =+  mkDocTest "All errors belong to some entrypoint" $+  \contractDoc ->+    forM_ (allContractLayers contractDoc) $ \(mGroup, block) ->+      case lookupDocBlockSection @DThrows block of+        Nothing -> pass+        Just (DThrows (_ :: Proxy err) :| _) ->+          if | Just DEntrypointDocItem{} <- mGroup -> pass+                -- Internal errors might be freely used everywhere and we do not+                -- display them on per-entrypoint basis, so we don't really care+                -- if they appear outside of all entrypoints+              | isInternalErrorClass (errorDocClass @err) -> pass+              | otherwise -> assertFailure . fmt $+                "Found an error `" +|| typeRep (Proxy @err) ||+ "` \+                \thrown outside of any entrypoint.\n\n\+                \If this should not belong to any existing entrypoint,\n\+                \consider marking the code as common for other entrypoints using\n\+                \CommonContractBehaviourKind or CommonEntrypointsBehaviourKind."++-- | Tests all properties.+testLorentzDoc :: [DocTest]+testLorentzDoc = mconcat+  [ testDocBasic+  , [ testDeclaresParameter+    , testNoAdjacentEpDescriptions+    , testEachEntrypointIsDescribed+    , testParamBuildingStepsAreFinalized+    , testAllEntrypointsAreCallable+    , testAllErrorsBelongToEntrypoints+    ]+  ]
+ src/Test/Cleveland/Doc/Michelson.hs view
@@ -0,0 +1,142 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Testing predicates for documentation of Michelson contracts+module Test.Cleveland.Doc.Michelson+  ( testDocBasic++    -- ** Individual test predicates+  , testContractNameAtTop+  , testNoGitInfo+  , testDocNotEmpty+  , testNoAdjacentDescriptions+  , testStorageIsDocumented++    -- ** Re-exports+  , module Test.Cleveland.Doc.Common+  ) where++import qualified Data.Text as T+import Data.Text.Lazy.Builder (toLazyText)+import Fmt (blockListF, fmt, nameF)+import Test.HUnit (assertBool, assertFailure)++import Morley.Michelson.Doc+import Morley.Michelson.Typed.Haskell.Doc+import Morley.Util.Text (dquotes)+import Test.Cleveland.Doc.Common++----------------------------------------------------------------------------+-- Test predicates+----------------------------------------------------------------------------++-- Basic predicates+----------------------------------------------------------------------------++-- | Check that contract documentation is wrapped with @contractName@.+testContractNameAtTop :: DocTest+testContractNameAtTop =+  mkDocTest "The whole contract is wrapped into 'DName'" $+  \contractDoc -> do+    let mSections = lookupDocBlockSection @DName (cdContents contractDoc)+    case mSections of+      Nothing -> assertFailure "There is no 'DName' at the top"+      Just _ -> return ()++-- | Check that contracts themselves do not set the git revision. It is supposed to be filled only+-- in the executable.+testNoGitInfo :: DocTest+testNoGitInfo =+  mkDocTest "Git revision is not set in the contract" $+  \contractDoc -> do+    found <- forM (allContractDocItems contractDoc) $ \case+      DGitRevisionUnknown -> return ()+      _ -> assertFailure+        "Git revision already attached.\n\+        \This is considered a bad practice to attach it right in the library\n\+        \because updating git info will require more modules to rebuild.\n\n\+        \Consider using `DGitRevisionUnknown` in the contract and then\n\+        \`attachGitInfo` in executable, or derivative methods."+    case found of+      [] -> assertFailure+        "No Git revision placeholder found, Git info won't be included.\n\+        \Consider inserting 'contractGeneralDefault' to your contract."+      [()] -> pass+      _ -> assertFailure+        "Too many `DGitRevisionUnknown`s in the contract."++-- | Check that there is at least one non-grouping doc item.+--+-- If there is no such, rendered documentation will be empty which signals about+-- most of the documentation pieces being lost.+testDocNotEmpty :: DocTest+testDocNotEmpty =+  mkDocTest "There is at least one DOC_ITEM" $+  \contractDoc ->+    assertBool "No doc items found" $+      any hasDocItem (allContractLayers contractDoc)+  where+    hasDocItem (_, block) = not . null @[()] $ do+      DocSection docElems <- toList block+      docElem <- toList docElems+      guard (deIsAtomic docElem)++-- | Check that no group contains two 'DDescription' items.+--+-- Normally such behaviour is allowed and can be exploited, but often it is not+-- and multiple descriptions appearence under the same group signals about+-- missing grouping wrapper (e.g. use of 'Lorentz.caseT' instead of 'Lorentz.entryCase').+testNoAdjacentDescriptions :: DocTest+testNoAdjacentDescriptions =+  mkDocTest "No two 'DDescription' appear under the same group" $+  \contractDoc ->+    forM_ (allContractLayers contractDoc) $ \(_, block) ->+      case lookupDocBlockSection @DDescription block of+        Just ds@(_ :| _ : _) ->+          let txts = ds <&> \(DDescription txt) -> txt+          in assertFailure . fmt $+             nameF "Found multiple adjacent descriptions" $+             blockListF $ map dquotes txts+        _ -> pass++-- | Check that all descriptions are proper.+testDescriptionsAreWellFormatted :: DocTest+testDescriptionsAreWellFormatted =+  mkDocTest "Descriptions are well-formatted" $+  \contractDoc ->+    let res =+          allContractDocItems contractDoc <&> \(DDescription desc) ->+            check (toText $ toLazyText desc)+    in case nonEmpty . catMaybes $ leftToMaybe <$> res of+      Nothing -> pass+      Just errs -> assertFailure . fmt $+        "Some descripions are not well formatted:\n" <> blockListF errs+  where+    check desc+      | T.null desc =+          Left "Empty description."+      | T.last (T.stripEnd desc) /= '.' =+          Left $ "Description does not end with a dot:\n\"" <>+                 toString desc <> "\""+      | otherwise = pass++-- | Test whether storage documentation is included in the contract's documentation.+testStorageIsDocumented :: DocTest+testStorageIsDocumented =+  mkDocTest "Storage documentation is included" $+  \contractDoc ->+    assertBool "No documentation for storage in the contract.\+               \Consider using `dStorage` to attach it." $+      not . null $ allContractDocItems @DStorageType contractDoc++-- | Base properties which should comply for all documentations.+testDocBasic :: [DocTest]+testDocBasic =+  [ testContractNameAtTop+  , testNoGitInfo+  , testDocNotEmpty+  , testNoAdjacentDescriptions+  , testDescriptionsAreWellFormatted+  , testStorageIsDocumented+  ]
+ src/Test/Cleveland/Ingredients.hs view
@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Ingredients that we use in our test suites.++module Test.Cleveland.Ingredients+  ( ourIngredients+  ) where++import Test.Tasty.Ingredients (Ingredient, composeReporters)+import Test.Tasty.Ingredients.Basic (consoleTestReporter, listingTests)+import Test.Tasty.Runners.AntXML (antXMLRunner)++-- | This is the default set of ingredients extended with the+-- 'antXMLRunner' which is used to generate xml reports for CI.+ourIngredients :: [Ingredient]+ourIngredients = [listingTests, antXMLRunner `composeReporters` consoleTestReporter]
+ src/Test/Cleveland/Instances.hs view
@@ -0,0 +1,110 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Cleveland.Instances+  ( HasInstrCallStack (..)+  ) where++import Fmt (Buildable(..), tupleF)+import qualified GHC.Num (fromInteger)+import Morley.Michelson.Text (MText, unsafeMkMText)+import Morley.Michelson.Typed.Haskell.Value (BigMap(..))+import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped.Annotation (Annotation(..), unsafeMkAnnotation)+import Morley.Tezos.Core (Mutez(..), unsafeAddMutez, unsafeMkMutez, unsafeMulMutez, unsafeSubMutez)++instance IsString (Annotation tag) where+  fromString = unsafeMkAnnotation . toText++instance IsString MText where+  fromString = unsafeMkMText . toText++instance Num Mutez where++  (+) = unsafeAddMutez++  (-) = unsafeSubMutez++  (*) a b = unsafeMulMutez a $ fromIntegral $ unMutez b++  abs = unsafeMkMutez . abs . unMutez++  signum = unsafeMkMutez . signum . unMutez++  fromInteger = unsafeMkMutez . fromInteger++deriving newtype instance Real Mutez+deriving newtype instance Integral Mutez++-- | This instance is declared in this test module because it's not lawful,+-- i.e. it breaks the right and left-identity laws:+--+-- @+-- x = BigMap (Just 1) mempty :: BigMap Int Int+-- bmId (x <> mempty) == bmId x+-- False+-- bmId (mempty <> x) == bmId x+-- False+-- @+instance Ord k => Monoid (BigMap k v) where+  mempty = BigMap Nothing mempty++-- | This instance is declared in this test module because it's not lawful,+-- i.e. it breaks the substitutivity law.+--+-- This laws says that @x == y@ implies @f x == f y@, however:+--+-- @+-- x = BigMap (Just 1) mempty :: BigMap Int Int+-- y = BigMap (Just 2) mempty :: BigMap Int Int+-- x == y+-- True+-- bmId x == bmId y+-- False+-- @+instance (Eq k, Eq v) => Eq (BigMap k v) where+  BigMap _ bm1 == BigMap _ bm2 = bm1 == bm2++instance (Buildable a, Buildable b) => Buildable (a, b) where build = tupleF+instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where build = tupleF+instance (Buildable a, Buildable b, Buildable c, Buildable d) => Buildable (a, b, c, d) where build = tupleF++-- | Class of types with t'Morley.Michelson.ErrorPos.InstrCallStack' allowing to remove it.+-- Can be used in tests when we want to compare only values without callstack.+class HasInstrCallStack a where+  withoutIcs :: a -> a++withoutIcs' :: (Functor f, HasInstrCallStack a) =>  f a -> f a+withoutIcs' = fmap withoutIcs++instance HasInstrCallStack U.ExpandedOp where+  withoutIcs = \case+    U.SeqEx ops'     -> U.SeqEx $ withoutIcs' ops'+    U.WithSrcEx _ op -> withoutIcs op+    U.PrimEx instr   -> U.PrimEx $ withoutIcs instr++instance HasInstrCallStack U.ExpandedInstr where+  withoutIcs = \case+    U.PUSH va ty v              -> U.PUSH va ty $ withoutIcs v+    U.IF_NONE ops1 ops2         -> U.IF_NONE (withoutIcs' ops1) (withoutIcs' ops2)+    U.IF_LEFT ops1 ops2         -> U.IF_LEFT (withoutIcs' ops1) (withoutIcs' ops2)+    U.IF_CONS ops1 ops2         -> U.IF_CONS (withoutIcs' ops1) (withoutIcs' ops2)+    U.MAP va ops                -> U.MAP va (withoutIcs' ops)+    U.ITER ops                  -> U.ITER $ withoutIcs' ops+    U.IF ops1 ops2              -> U.IF (withoutIcs' ops1) (withoutIcs' ops2)+    U.LOOP ops                  -> U.LOOP $ withoutIcs' ops+    U.LOOP_LEFT ops             -> U.LOOP_LEFT $ withoutIcs' ops+    U.LAMBDA va ty1 ty2 ops     -> U.LAMBDA va ty1 ty2 (withoutIcs' ops)+    U.DIP ops                   -> U.DIP $ withoutIcs' ops+    U.DIPN n ops -> U.DIPN n (withoutIcs' ops)+    U.CREATE_CONTRACT va1 va2 c ->+      U.CREATE_CONTRACT va1 va2 (U.mapContractCode withoutIcs c)+    i                           -> i++instance HasInstrCallStack U.Value where+  withoutIcs = \case+    U.ValueLambda ops -> U.ValueLambda $ withoutIcs' ops+    v                 -> v
+ src/Test/Cleveland/Internal/Abstract.hs view
@@ -0,0 +1,716 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Abstract cleveland interface not bound to a particular+-- implementation.+--+-- The interface may look a bit untyped and unsafe in some places.+-- For example, in order to call a contract one should supply a+-- simple address rather than a contract ref, so it is easy to pass+-- a value of wrong type. Also it is easy to call a non-existing entrypoint.+--+-- Subjectively, it makes writing test scenarios easier because you+-- have to prove less to the compiler. It also makes implementation of+-- cleveland engine a bit easier. Of course, it also makes it easier+-- to make certain mistakes. However, we expect users of this interface+-- to also use the functionality of the "Test.Cleveland.Internal.Pure" module+-- and convert cleveland scenarios to purely testable scenarios for+-- integrational testing engine. In this case errors should be detected+-- almost as quickly as they would reported by the compiler, at least+-- before trying to run scenario on a live network.+--+-- Also this interface uses 'Address' rather than 'EpAddress'.+-- I (\@gromak) concluded that 'EpAddress' can not be passed to @tezos-client@.+-- For key addresses it just does not make sense and for contract addresses+-- I get such errors:+--+-- @+--   bad contract notation+--   Invalid contract notation "KT1VrFpBPwBTm3hsK7DB7SPmY8fTHJ3vY6sJ%mint"+-- @+module Test.Cleveland.Internal.Abstract+  ( ContractHandle (..)+  , OriginateData (..)+  , TransferData (..)+  , Sender (..)+  , Moneybag (..)+  , UntypedOriginateData (..)+  , BaseOperationData (..)+  , BaseOperationResult (..)++  , DefaultAliasCounter (..)+  , SpecificOrDefaultAliasHint (..)++  -- * Actions+  , ClevelandOpsImpl (..)+  , ClevelandMiscImpl (..)+  , EmulatedImpl(..)++  , mapClevelandOpsImplExceptions+  , mapClevelandMiscImplExceptions++  -- * Batching+  , BatchResultMismatch(..)+  , ClevelandOpsBatch+  , runBatched+  , batchedOpsImpl+  , runOperationBatchM+  , runSingleOperation++  -- * Validation+  , TransferFailure (..)+  , TransferFailureReason (..)+  , FailedInBranch (..)+  , ScenarioBranchName(..)+  , GenericTestError (..)+  , ExpressionOrTypedValue (..)++  -- * Helpers+  , auto+  , ep+  , mkDefaultAlias++  -- * Morley client re-exports+  , AliasHint++  -- * Capability records+  , ClevelandCaps(..)+  , EmulatedCaps(..)+  , RunMode(..)+  , HasClevelandCaps(..)+  , HasEmulatedCaps(..)++  , MonadCleveland+  , MonadEmulated+  , ClevelandT+  , EmulatedT++  -- * Log utilities+  , LogsInfo+  , ScenarioLogs(..)+  , slAddr+  , slLog+  , logsL+  , filterLogsByAddrL+  , logsForAddress+  , collectLogs+  ) where++import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor)+import Data.Default (Default(..))+import Data.Type.Equality (pattern Refl)+import Data.Typeable (cast)+import Fmt (Buildable(..), Builder, pretty, (+|), (|+))+import Prelude hiding (Each)+import Time (KnownDivRat, Second, Time)++import Lorentz (Contract(..))+import Lorentz.Constraints+import Morley.Client (Alias, AliasHint)+import Morley.Micheline (Expression, fromExpression)+import Morley.Michelson.ErrorPos (InstrCallStack)+import Morley.Michelson.Interpret (MorleyLogs(..))+import Morley.Michelson.Runtime (VotingPowers)+import Morley.Michelson.Typed (BigMapId)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.AnnotatedValue (SomeAnnotatedValue)+import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Scope (ConstantScope)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import qualified Morley.Tezos.Crypto as Crypto+import Morley.Util.Batching+import Morley.Util.Sing (eqI)+import Morley.Util.TypeLits+import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Lorentz.Types++data OriginateData param st vd =+  OriginateData+  { odName :: AliasHint+  -- ^ Alias for the originated contract.+  , odBalance :: Mutez+  -- ^ Initial balance.+  , odStorage :: st+  -- ^ Initial storage.+  , odContract :: Contract param st vd+  -- ^ The contract itself.+  --+  -- We are using Lorentz version here which is convenient. However, keep in+  -- mind that if someone wants to test a contract from @.tz@ file, they should use+  -- 'UntypedOriginateData'.+  }++-- | Untyped version of OriginateData. It can be used for interaction with raw+-- Michelson contracts+data UntypedOriginateData = UntypedOriginateData+  { uodName :: AliasHint+  -- ^ Alias for the originated contract.+  , uodBalance :: Mutez+  -- ^ Initial balance.+  , uodStorage :: U.Value+  -- ^ Initial storage.+  , uodContract :: U.Contract+  -- ^ The contract itself.+  }++-- | Information about transfer operation.+data TransferData =+  forall v addr. (NiceParameter v, ToAddress addr) => TransferData+  { tdTo :: addr+  -- ^ Receiver address for this transaction.+  , tdAmount :: Mutez+  -- ^ Amount to be transferred.+  , tdEntrypoint :: EpName+  -- ^ An entrypoint to be called. Consider using 'ep' in testing+  -- scenarios.+  , tdParameter :: v+  -- ^ Parameter that will be used for a contract call. Set to @()@+  -- for transfers to key addresses.+  }++-- | Datatype specifying creation of arbitrary operation.+data BaseOperationData+  = OriginateOp UntypedOriginateData+  | TransferOp TransferData++-- | Datatype specifying result of operation run.+data BaseOperationResult+  = OriginateResult Address+  | TransferResult++-- | A batch returned invalid output, e.g. origination address when transaction+-- was supplied.+data BatchResultMismatch+  = BatchResultMismatch Text  -- ^ Carries expected operation type in lowercase++instance Buildable BatchResultMismatch where+  build = \case+    BatchResultMismatch expected ->+      "For " +| expected |+ " operation received inappropriate result"++-- | Designates the special sender address.+--+-- Transfers and some other operations will occur on behalf of this address.+-- This is initialized to @moneybag@ address and then can be locally modified.+--+-- Operations in `ClevelandOpsImpl` are affected by this address.+newtype Sender = Sender { unSender :: Address }++-- | Designates the address that gifts money to new addresses.+--+-- Once a new address is allocated in a test scenario, we have to transfer some+-- money to it so that it is able to serve as transactions sender. 'Moneybag'+-- serves as a source of that money.+--+-- We do not use 'Sender' for this purpose because in most situations changing+-- moneybag is not necessary. If a user wraps a large piece of their script with+-- 'Test.Cleveland.withSender' call and that changes the moneybag - this behaviour may be+-- undesired and unexpected to the user.+newtype Moneybag = Moneybag { unMoneybag :: Address }++-- | An alias hint with default value that can be used to define unique alias+-- automatically.+data SpecificOrDefaultAliasHint+  = SpecificAliasHint AliasHint+  | DefaultAliasHint+  deriving stock (Show)++instance IsString SpecificOrDefaultAliasHint where+  fromString = SpecificAliasHint . fromString++instance Default SpecificOrDefaultAliasHint where+  def = DefaultAliasHint++mkDefaultAlias :: Natural -> AliasHint+mkDefaultAlias counter =+  fromString $ ("default_cleveland_alias" <> show counter)++-- | Helper to use automatically determined unique alias.+auto :: SpecificOrDefaultAliasHint+auto = def++-- | Counter which is used to provide different default aliases.+newtype DefaultAliasCounter = DefaultAliasCounter {unDefaultAliasCounter :: Natural}++-- | A record data type with operations creating primitives.+data ClevelandOpsImpl m = ClevelandOpsImpl+  { coiRunOperationBatch+      :: HasCallStack => [BaseOperationData] -> m [BaseOperationResult]+  -- ^ Perform a batch of operations.+  }++-- | A record data type with all base methods one can use during a cleveland test.+data ClevelandMiscImpl m = ClevelandMiscImpl+  { cmiRunIO :: forall res. HasCallStack => IO res -> m res+  -- ^ Runs an 'IO' action.+  , cmiResolveAddress :: HasCallStack => Alias -> 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.+  -- If a key with this alias already exists, the corresponding address+  -- will be returned and no state will be changed.+  , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAliasHint -> m Address+  -- ^ Generate a secret key and store it with given alias.+  -- Unlike 'cmiGenKey' this function overwrites the existing key when+  -- given alias is already stored.+  , cmiSignBytes :: HasCallStack => ByteString -> Address -> m Crypto.Signature+  -- ^ Get the signature of the preapplied operation.+  , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData -> m Address+  -- ^ Originate a new raw Michelson contract that doesn't fit into the+  -- origination size limit, by executing multiple operation steps.+  --+  -- Note that this is not part of 'ClevelandOpsImpl' because large origination is+  -- _not_ a primitive operation. Also, it cannot appear in a batch (it simply+  -- may not fit).+  , cmiComment :: HasCallStack => Text -> m ()+  -- ^ Print the given string verbatim as a comment.+  -- At the moment, this is a no-op in emulator tests.+  , cmiGetBalance :: HasCallStack => Address -> m Mutez+  -- ^ Get the balance of the given address.+  , cmiGetSomeStorage :: HasCallStack => Address -> m SomeAnnotatedValue+  -- Retrieves the contract's storage.+  , cmiGetBigMapValueMaybe+      :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v)+      => BigMapId k v -> k -> m (Maybe v)+  -- ^ Retrieve a big_map value, given a big_map ID and a key.+  -- Returns 'Nothing' when the big_map ID does not exist, or it exists but+  -- does not contain the given key.+  , cmiGetAllBigMapValuesMaybe+      :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v)+      => BigMapId k v -> m (Maybe [v])+  -- ^ Retrieve all big_map values, given a big_map ID.+  -- Returns 'Nothing' when the big_map ID does not exist.+  , cmiGetPublicKey :: HasCallStack => Address -> m Crypto.PublicKey+  -- ^ Get the public key associated with the given address.+  -- Fail if the given address is not an implicit account.+  , cmiGetDelegate :: HasCallStack => Address -> m (Maybe Crypto.KeyHash)+  -- ^ Get the delegate for the given contract. Fails on implicit contracts.+  , cmiRegisterDelegate :: HasCallStack => Address -> m ()+  -- ^ Register the given address as a valid delegate.+  , cmiGetChainId :: HasCallStack => m ChainId+  -- ^ Get the chain's @ChainId@.+  , cmiAdvanceTime :: forall unit. (HasCallStack, KnownDivRat unit Second) => Time unit -> m ()+  -- ^ Advance at least the given amount of time, or until a new block is baked,+  -- whichever happens last.+  --+  -- On a real network, this is implemented using @threadDelay@, so it's advisable+  -- to use small amounts of time only.+  , cmiAdvanceToLevel :: HasCallStack => (Natural -> Natural) -> m ()+  -- ^ Advance at least to the level returned by the callback, accepting current level.+  , cmiGetNow :: HasCallStack => m Timestamp+  -- ^ Get the timestamp observed by the last block to be baked.+  , cmiGetLevel :: HasCallStack => m Natural+  -- ^ Get the current level observed by the last block to be baked.+  , cmiFailure :: forall a. HasCallStack => Builder -> m a+  -- ^ Fails the test with the given error message.+  , cmiThrow :: forall a. HasCallStack => SomeException -> m a+  -- ^ Rethrow arbitrary error without affecting the call stack. Used+  -- internally. You probably want to use 'cmiFailure'+  , cmiGetApproximateBlockInterval :: HasCallStack => m (Time Second)+  -- ^ Get approximate block interval in seconds. Note, that this value+  -- is minimal bound and real intervals can be larger.+  , cmiAttempt :: forall a e. (Exception e, HasCallStack) => m a -> m (Either e a)+  -- ^ Attempts to perform an action, returning either the result of the action or an exception.+  , cmiMarkAddressRefillable :: Address -> m ()+  -- ^ Marks a given address as "refillable", i.e. if the address lacks funds for the next operation,+  -- some funds will automatically be transferred to it.+  }++-- | A record data type with all base methods one can use during cleveland, but which are available+-- only when running on an emulated environment (e.g. "Morley.Michelson.Runtime") and not on a real network.+data EmulatedImpl m = EmulatedImpl+  { eiBranchout :: [(Text, m ())] -> m ()+  -- ^ Execute multiple testing scenarios independently.+  --+  -- * Actions performed before 'eiBranchout' will be observed by all branches.+  -- * Actions performed in branches will _not_ be observed by any actions performed after 'eiBranchout'.+  -- * Actions performed in one branch will _not_ be observed by another branch.+  -- * The test succeeds IFF all branches succeed.+  -- * If any branch fails, the test ends immediately and the remaining branches+  --    won't be executed.+  --+  -- The following property holds:+  --+  -- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c]+  --+  -- The list of branches must be non-empty.+  , eiGetStorage+      :: forall st addr. (HasCallStack, ToStorageType st addr)+      => addr -> m st+  -- ^ Retrieve a contract's full storage, including the contents of its big_maps.+  -- This function can only be used in emulator-only tests.+  , eiGetMorleyLogs :: forall a. m a -> m (LogsInfo, a)+  -- ^ Returns the result of the action with the logs it produced+  , eiSetVotingPowers :: VotingPowers -> m ()+  -- ^ Change voting power distribution.+  }++----------------------------------------------------------------------------+-- Log helpers+----------------------------------------------------------------------------++data ScenarioLogs = ScenarioLogs+  { _slAddr :: Address+  , _slLog :: MorleyLogs+  } deriving stock (Eq, Show)++type LogsInfo = [ScenarioLogs]++makeLenses ''ScenarioLogs++-- | An alias for 'slLog' with a clearer name+logsL :: Lens' ScenarioLogs MorleyLogs+logsL = slLog++-- | Lens combinator specified for filtering logs by address from 'LogsInfo'+filterLogsByAddrL+  :: (ToAddress addr, Applicative f)+  => addr+  -> (MorleyLogs -> f MorleyLogs)+  -> ScenarioLogs+  -> f ScenarioLogs+filterLogsByAddrL (toAddress -> addr) = filtered (\(ScenarioLogs a _) -> a == addr) . logsL++-- | Get logs for a given address from 'LogsInfo'+logsForAddress+  :: ( Each s s ScenarioLogs ScenarioLogs+     , ToAddress addr+     )+  => addr+  -> s+  -> [MorleyLogs]+logsForAddress addr = (^.. each . filterLogsByAddrL addr)++-- | Collect logs produced by all contracts into the single list+collectLogs :: LogsInfo -> MorleyLogs+collectLogs = foldMap _slLog++----------------------------------------------------------------------------+-- Batched operations+----------------------------------------------------------------------------++-- | Where the batched operations occur.+--+-- Note that this is not a 'Monad', rather an 'Applicative' - use+-- @-XApplicativeDo@ extension for nicer experience.+newtype ClevelandOpsBatch a = ClevelandOpsBatch+  { unClevelandOpsBatch+      :: BatchingM BaseOperationData BaseOperationResult Void a+  } deriving newtype (Functor, Applicative)++instance+  TypeError+  ( 'Text "Attempt to use monad capabilities within a batch" ':$$:+    'Text "In case you are using a do-block, make sure that" ':$$:+    'Text "• `ApplicativeDo` extension is enabled" ':$$:+    'Text "• there is a return statement in the end" ':$$:+    'Text "• returned value picks variables in the order in which they are defined"+  ) =>+  Monad ClevelandOpsBatch where+    (>>=) = error "impossible"++{- | Run a series of operations within a batch.++Example:++@+contract <- runBatched impl $ do+  -- this block is executed within 'ClevelandOpsBatch'+  contract <- runSingleOperation batchedOpsImpl "origination" ...+  for_ [1..3] \i ->+    runSingleOperation batchedOpsImpl "transfer" ...+  return contract+@++See 'ClevelandOpsBatch' for some precautions.+-}+runBatched+  :: (HasCallStack, Functor m)+  => ClevelandOpsImpl m+  -> ClevelandOpsBatch a+  -> m a+runBatched impl =+  runOperationBatchM (Proxy @Void) impl . unClevelandOpsBatch++-- | 'ClevelandOpsImpl' suitable for methods executed within a batch.+batchedOpsImpl :: ClevelandOpsImpl ClevelandOpsBatch+batchedOpsImpl = ClevelandOpsImpl+  { coiRunOperationBatch = ClevelandOpsBatch . traverse (`submitThenParse` pure)+  }++-- | Version of 'coiRunOperationBatch' that uses 'BatchingM'.+--+-- This is an internal function.+--+-- Invariant: all errors described by @e@ must be internal and should not occur+-- in practice (we require @e@ type to be specified explicitly to hinder+-- incorrect usage).+runOperationBatchM+  :: (HasCallStack, Buildable e, Functor m)+  => Proxy e+  -> ClevelandOpsImpl m+  -> BatchingM BaseOperationData BaseOperationResult e a+  -> m a+runOperationBatchM _ impl =+  fmap snd . unsafeRunBatching (fmap ((), ) . coiRunOperationBatch impl)++-- | Helper that runs a single operation using 'ClevelandOpsImpl'.+runSingleOperation+  :: (HasCallStack, Functor m)+  => ClevelandOpsImpl m+  -> Text+  -> BaseOperationData+  -> (BaseOperationResult -> Maybe a)+  -> m a+runSingleOperation impl desc opData parseRes =+  runOperationBatchM (Proxy @BatchResultMismatch) impl $+    opData `submitThenParse` maybeToRight (BatchResultMismatch desc) . parseRes++----------------------------------------------------------------------------+-- Validation+----------------------------------------------------------------------------++-- | Representation of Expression we got from the RPC or a typed value we+-- got from the emulator.+data ExpressionOrTypedValue where+  EOTVExpression :: Expression -> ExpressionOrTypedValue+  EOTVTypedValue :: (T.SingI t, ConstantScope t) => T.Value t -> ExpressionOrTypedValue++deriving stock instance Show ExpressionOrTypedValue+instance Eq ExpressionOrTypedValue where+  (==) (EOTVExpression x) (EOTVExpression y) = x == y+  (==) (EOTVTypedValue (x :: T.Value t)) (EOTVTypedValue (y :: T.Value u))+    = case eqI @t @u of+      Just Refl -> x == y+      Nothing -> False+  (==) _ _ = False++instance Buildable ExpressionOrTypedValue where+  build = \case+    EOTVExpression e -> either (const $ build e) build $ fromExpression @U.Value e+    EOTVTypedValue v -> build v++-- | Failures that could be expected in the execution of a transfer.+-- These can be caught and handled with 'Test.Cleveland.attempt'.+data TransferFailure = TransferFailure+  { tfAddress :: Address+  , tfReason :: TransferFailureReason+  } deriving stock (Show, Eq)++data TransferFailureReason+  = FailedWith ExpressionOrTypedValue (Maybe InstrCallStack)+  -- ^ Expect that interpretation of contract with the given address ended+  -- with @FAILWITH@.+  | EmptyTransaction+  -- ^ Expect failure due to an attempt to transfer 0tz towards a simple address.+  | BadParameter+  -- ^ Expect failure due to an attempt to call a contract with an invalid parameter.+  | MutezArithError T.MutezArithErrorType+  -- ^ Expect failure due to an arithmetic over-/underflow+  | ShiftOverflow+  -- ^ Expect that interpretation of contract with the given address ended+  -- with an overflow error.+  | GasExhaustion+  -- TODO: [#284] add more errors here!+  deriving stock (Show, Eq)++-- | When an exception is thrown in a 'Test.Cleveland.branchout' branch, we wrap it in this+-- constructor to remember in _which_ branch it was thrown.+-- We use this information to provide better error messages when a test fails.+data FailedInBranch = FailedInBranch ScenarioBranchName SomeException+  deriving stock (Show)++-- | When using 'Test.Cleveland.branchout' function for building test scenarios - names+-- of branches we are currently within.+newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }+  deriving stock (Show, Eq)++instance Buildable ScenarioBranchName where+  build = mconcat . intersperse "/" . map build . unTestBranch++instance Buildable TransferFailure where+  build (TransferFailure addr reason) = case reason of+    EmptyTransaction -> reason |+ ": " +| addr |+ ""+    BadParameter -> "Attempted to call contract " +| addr |+ " with a " +| reason |+ ""+    FailedWith{} -> "Contract: " +| addr |+ " " +| reason |+ ""+    _ -> "Contract: " +| addr |+ " failed due to a " +| reason |+ ""++instance Buildable TransferFailureReason where+  build = \case+    FailedWith expr loc -> "failed with: " +| expr |++      maybe "" (" at " +|) (build <$> loc)+    EmptyTransaction -> "Attempted to transfer 0tz to a simple address"+    BadParameter -> "parameter of the wrong type"+    MutezArithError typ -> "mutez " +| typ |+ ""+    ShiftOverflow -> "overflow error"+    GasExhaustion -> "gas exhaustion"++instance Buildable FailedInBranch where+  build (FailedInBranch branchName (SomeException err)) = "In '" +| branchName |++    "' branch:\n" +| (build $ displayException err)++data GenericTestError+  = UnexpectedSuccess+  deriving stock Show++instance Buildable GenericTestError where+  build = \case+    UnexpectedSuccess ->+      "Expected an exception to be thrown, but it wasn't"++instance Exception TransferFailure where+  displayException = pretty+  fromException someEx@(SomeException ex) =+    cast @_ @TransferFailure ex+    <|>+    ( do+        WithCallStack _ exInner <- fromException @WithCallStack someEx+        fromException exInner+    )+    <|>+    ( do+        FailedInBranch _ exInner <- fromException @FailedInBranch someEx+        fromException exInner+    )+++instance Exception FailedInBranch where+  displayException = pretty++instance Exception GenericTestError where+  displayException = pretty++----------------------------------------------------------------------------+-- Other helpers+----------------------------------------------------------------------------++-- | A short partial constructor for 'EpName'. It is supposed to be+-- applied to string constants, so programmer is responsible for+-- validity. And this code is for tests anyway, so each failure is a+-- programmer mistake.+--+-- It is intentionally here and not in some deeper module because the+-- name is really short and more suitable for writing scenarios.+ep :: HasCallStack => Text -> EpName+ep = U.unsafeBuildEpName++-- | Runs a handler over every action.+mapClevelandOpsImplExceptions+  :: (forall a. HasCallStack => m a -> m a)+  -> ClevelandOpsImpl m -> ClevelandOpsImpl m+mapClevelandOpsImplExceptions f ClevelandOpsImpl{..} = ClevelandOpsImpl+    { coiRunOperationBatch = \op -> f $ coiRunOperationBatch op+    }++-- | Runs a handler over every action (except 'cmiAttempt' and 'cmiThrow'),+-- possibly transforming exceptions thrown by those actions.+mapClevelandMiscImplExceptions+  :: (forall a. HasCallStack => m a -> m a)+  -> ClevelandMiscImpl m -> ClevelandMiscImpl m+mapClevelandMiscImplExceptions f ClevelandMiscImpl{..} = ClevelandMiscImpl+    { cmiRunIO = \action -> f $ cmiRunIO action+    , cmiResolveAddress = \address -> f $ cmiResolveAddress address+    , cmiSignBytes = \bs alias -> f $ cmiSignBytes bs alias+    , cmiGenKey = \aliasHint -> f $ cmiGenKey aliasHint+    , cmiGenFreshKey = \aliasHint -> f $ cmiGenFreshKey aliasHint+    , cmiOriginateLargeUntyped = \sender uodata -> f $ cmiOriginateLargeUntyped sender uodata+    , cmiComment = \t -> f $ cmiComment t+    , cmiGetBalance = \addr -> f $ cmiGetBalance addr+    , cmiGetSomeStorage = \addr -> f $ cmiGetSomeStorage addr+    , cmiGetBigMapValueMaybe = \bmId k -> f $ cmiGetBigMapValueMaybe bmId k+    , cmiGetAllBigMapValuesMaybe = \bmId -> f $ cmiGetAllBigMapValuesMaybe bmId+    , cmiGetPublicKey = \addr -> f $ cmiGetPublicKey addr+    , cmiGetDelegate = f <$> cmiGetDelegate+    , cmiRegisterDelegate = f <$> cmiRegisterDelegate+    , cmiGetChainId = f $ cmiGetChainId+    , cmiAdvanceTime = \time -> f $ cmiAdvanceTime time+    , cmiAdvanceToLevel = \level -> f $ cmiAdvanceToLevel level+    , cmiGetNow = f $ cmiGetNow+    , cmiGetLevel = f $ cmiGetLevel+    , cmiFailure = \builder -> f $ cmiFailure builder+    , cmiGetApproximateBlockInterval = f $ cmiGetApproximateBlockInterval+    , cmiAttempt = \action -> cmiAttempt action+    , cmiMarkAddressRefillable = f . cmiMarkAddressRefillable+    , cmiThrow = cmiThrow+    }++-- | A record with all the capabilities available to any cleveland test.+data ClevelandCaps m = ClevelandCaps+  { ccSender :: Sender+  , ccMoneybag :: Moneybag+  , ccMiscCap :: ClevelandMiscImpl m+  , ccOpsCap :: Sender -> ClevelandOpsImpl m+  }++-- | A record with all the capabilities available to a cleveland test on the emulator.+data EmulatedCaps m = EmulatedCaps+  { ecEmulatedCap :: EmulatedImpl m+  , ecClevelandCaps :: ClevelandCaps m+  }++makeLensesFor [("ccSender", "ccSenderL"), ("ccMoneybag", "ccMoneybagL")] ''ClevelandCaps+makeLensesFor [("ecClevelandCaps", "ecClevelandCapsL")] ''EmulatedCaps++-- | In which mode the test suite is currently executed.+data RunMode caps where+  -- | Test is run on-chain.+  NetworkMode :: RunMode caps+  -- | Test is run in Morley emulation.+  EmulationMode :: HasEmulatedCaps caps => RunMode caps++-- | A proof that the given @caps@ record contains+-- the basic cleveland capabilities.+class Monad (ClevelandBaseMonad caps) => HasClevelandCaps caps where+  -- | This will be either @PureM@ or @ClientM@.+  type ClevelandBaseMonad caps :: Type -> Type+  senderL :: Lens' caps Sender+  moneybagL :: Lens' caps Moneybag+  getMiscCap :: caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)+  getOpsCap :: caps -> ClevelandOpsImpl (ClevelandBaseMonad caps)+  runMode :: RunMode caps++-- | A proof that the given @caps@ record contains+-- the basic cleveland capabilities + the emulator capabiilities.+class HasClevelandCaps caps => HasEmulatedCaps caps where+  getEmulatedCap :: caps -> EmulatedImpl (ClevelandBaseMonad caps)++instance Monad m => HasClevelandCaps (ClevelandCaps m) where+  type ClevelandBaseMonad (ClevelandCaps m) = m+  senderL = ccSenderL+  moneybagL = ccMoneybagL+  getMiscCap = ccMiscCap+  getOpsCap r = ccOpsCap r (r ^. senderL)+  runMode = NetworkMode++instance Monad m => HasClevelandCaps (EmulatedCaps m) where+  type ClevelandBaseMonad (EmulatedCaps m) = m+  senderL = ecClevelandCapsL . senderL+  moneybagL = ecClevelandCapsL . moneybagL+  getMiscCap = getMiscCap . ecClevelandCaps+  getOpsCap = getOpsCap . ecClevelandCaps+  runMode = EmulationMode++instance Monad m => HasEmulatedCaps (EmulatedCaps m) where+  getEmulatedCap = ecEmulatedCap++-- | Constraint for a monad in which we can do cleveland actions.+type MonadCleveland caps m =+  ( m ~ ReaderT caps (ClevelandBaseMonad caps)+  , HasClevelandCaps caps+  )++-- | Constraint for a monad in which we can do cleveland actions that can't be run on a real network.+-- It requires the 'EmulatedImpl' capability.+type MonadEmulated caps m =+  ( MonadCleveland caps m+  , HasEmulatedCaps caps+  )++-- | Monad transformer that adds only the 'ClevelandCaps' capabilities.+type ClevelandT m = ReaderT (ClevelandCaps m) m++-- | Monad transformer that adds both 'ClevelandCaps' and 'EmulatedCaps' capabilities.+type EmulatedT m = ReaderT (EmulatedCaps m) m
+ src/Test/Cleveland/Internal/Actions.hs view
@@ -0,0 +1,1158 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Cleveland actions.+module Test.Cleveland.Internal.Actions+  ( MonadOps(..)+  , withSender+  , withMoneybag+  , runIO+  , resolveAddress+  , refillable+  , newAddress+  , newFreshAddress+  , signBytes+  , signBinary+  , originate+  , originateSimple+  , originateUntyped+  , originateUntypedSimple+  , originateTypedSimple+  , originateLarge+  , originateLargeSimple+  , originateLargeUntyped+  , originateLargeUntypedSimple+  , transfer+  , transferMoney+  , call+  , inBatch+  , importUntypedContract+  , importContract+  , noViews+  , comment+  , getBalance+  , getStorage+  , getFullStorage+  , getSomeStorage+  , getAllBigMapValues+  , getAllBigMapValuesMaybe+  , getBigMapSize+  , getBigMapSizeMaybe+  , getBigMapValueMaybe+  , getBigMapValue+  , getMorleyLogs+  , getMorleyLogs_+  , getPublicKey+  , getChainId+  , advanceTime+  , advanceLevel+  , advanceToLevel+  , getNow+  , getLevel+  , getApproximateBlockInterval+  , branchout+  , offshoot+  , getDelegate+  , registerDelegate+  , setVotingPowers+  , getRunMode+  , whenEmulation++  -- * Assertions+  , failure+  , assert+  , (@==)+  , (@/=)+  , (@@==)+  , (@@/=)+  , checkCompares+  , checkComparesWith+  , evalJust+  , evalRight++  -- * Exception handling+  , attempt+  , catchTransferFailure+  , checkTransferFailure+  , expectTransferFailure+  , expectFailedWith+  , expectError+  , expectCustomError+  , expectCustomError_+  , expectCustomErrorNoArg+  , expectNumericError+  , clarifyErrors+  -- ** TransferFailure predicates+  , TransferFailurePredicate(..)+  , shiftOverflow+  , emptyTransaction+  , badParameter+  , gasExhaustion+  , failedWith+  , addressIs+  -- ** @FAILWITH@ errors+  , constant+  , lerror+  , customError+  , customError_+  , customErrorNoArg+  , numericError++  -- * Helpers+  , withCap+  ) where++import Data.Constraint (Dict(Dict), (\\))+import Data.Either.Validation (Validation(..))+import qualified Data.List.NonEmpty as NE+import Data.Singletons (demote)+import Fmt (Buildable, Builder, build, indentF, nameF, pretty, unlinesF, (+|), (|+))+import Time (KnownDivRat, Second, Time)+import qualified Unsafe (fromIntegral)++import Lorentz+  (BigMapId, Contract(..), CustomError(..), DemoteViewsDescriptor, ErrorTagMap,+  HasEntrypointArg(useHasEntrypointArg), IsError, IsoValue, Label, MText, MustHaveErrorArg,+  ToTAddress, errorTagToMText, errorToVal, errorToValNumeric, noViews, pattern DefEpName,+  toMichelsonContract, toMutez, toTAddress, toVal, zeroMutez)+import Lorentz.Bytes+import Lorentz.Constraints+import Morley.Client (Alias, AsRPC)+import Morley.Micheline (Expression, FromExpression(..), toExpression)+import Morley.Michelson.Printer.Util (buildRenderDoc)+import Morley.Michelson.Runtime (VotingPowers)+import qualified Morley.Michelson.Runtime.Import as Runtime+import Morley.Michelson.Typed+  (SomeAnnotatedValue, SomeConstant(..), ToT, convertContract, untypeValue)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)+import Test.Cleveland.Internal.Abstract+import qualified Test.Cleveland.Internal.Client as Client (TestError(..))+import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Pure as Pure (TestError(..))+import qualified Test.Cleveland.Lorentz.Import as LorentzImport+import Test.Cleveland.Lorentz.Types++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++-- | Typeclass for monads where operations-related actions can occur.+--+-- This is implemented for 'MonadCleveland' and batch context.+--+-- Has 'Functor' as a superclass constraint for convenience, all the related methods+-- require it.+class Functor m => MonadOps m where+  -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\".+  --+  -- In CPS style, because the \"monad\" can be actually not a monad, so+  -- it can't work like 'ask' for 'ReaderT'.+  withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a++instance MonadOps ClevelandOpsBatch where+  withOpsCap mkAction = mkAction batchedOpsImpl++instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOps (ReaderT caps m) where+  withOpsCap mkAction = do+    opsCap :: ClevelandOpsImpl m <- asks getOpsCap+    let opsCap' :: ClevelandOpsImpl (ReaderT caps m) =+          ClevelandOpsImpl+            { coiRunOperationBatch =  lift ... coiRunOperationBatch opsCap+            }+    mkAction opsCap'++-- | Update the current sender on whose behalf transfers and originations are+-- invoked.+withSender :: MonadCleveland caps m => Address -> m a -> m a+withSender addr =+  local (set senderL (Sender addr))++-- | Update the current moneybag that transfers money on the newly created+-- addresses. For the rare occasions when this is necessary.+withMoneybag :: MonadCleveland caps m => Address -> m a -> m a+withMoneybag addr =+  local (set moneybagL (Moneybag addr))++-- | Runs an 'IO' action.+runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res+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+resolveAddress alias = do+  withCap getMiscCap \cap -> cmiResolveAddress cap alias++-- | Simple combinator that marks address as "refillable".+--+-- If a refillable address lacks funds for the next operation,+-- some funds will automatically be transferred to it.+refillable :: MonadCleveland caps m => m Address -> m Address+refillable action = do+  addr <- action+  withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr+  pure addr++-- | If the given alias is already associated with an existing address,+-- that address will be reused and returned.+-- Otherwise, generate a new secret key and record it with given alias.+--+-- If the account has too low of a balance, a small amount of XTZ will+-- be transferred to it.+--+-- Notes:+--+-- * By default, the XTZ is transferred from the account associated with the @moneybag@ alias.+--   This can be overriden with the @--cleveland-moneybag-alias@ command line option, the+--   @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'.+-- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias hint.+--   An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the+--   @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'.+--     > do+--     >   addr1 <- newAddress "alias"+--     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"+--     >   addr1 @== addr2+newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address+newAddress alias = do+  addr <- withCap getMiscCap \cap -> cmiGenKey cap alias+  Moneybag moneybag <- view moneybagL++  -- The address may exist from previous scenarios runs and have sufficient+  -- balance for the sake of testing; if so, we can save some time+  balance <- getBalance addr+  when (balance < toMutez 0.5_e6) do  -- < 0.5 XTZ+    withSender moneybag do+      transferMoney addr (toMutez 0.9_e6) -- 0.9 XTZ+  pure addr++-- | Generate a new secret key and record it with given alias. If the+-- alias is already known, the key will be overwritten. The address is+-- guaranteed to be fresh, i. e. no operations on it have been made.+--+-- Notes:+--+-- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias.+--   An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the+--   @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'.+--     > do+--     >   addr1 <- newFreshAddress "alias"+--     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"+--     >   addr1 @== addr2+newFreshAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address+newFreshAddress aliasHint = do+  withCap getMiscCap \cap -> cmiGenFreshKey cap aliasHint++-- | Get the signature of the preapplied operation.+signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> Address -> m Signature+signBytes bytes signer = do+  withCap getMiscCap \cap -> cmiSignBytes cap bytes signer++-- | Type-safer version of 'signBytes'.+signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs)+signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr++-- | Originate a new raw Michelson contract with given data.+originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address+originateUntyped uod = withOpsCap \opsCap ->+  runSingleOperation opsCap "origination" (OriginateOp uod) \case+    OriginateResult addr -> Just addr+    _ -> Nothing++-- | A simplified version of the originateUntyped command.+-- The contract will have 0 balance.+originateUntypedSimple+  :: (HasCallStack, MonadOps m) => AliasHint -> U.Value -> U.Contract -> m Address+originateUntypedSimple uodName uodStorage uodContract = do+  let uodBalance = zeroMutez+  originateUntyped UntypedOriginateData{..}++-- | Lorentz version for origination.+--+-- By default, the sender is the account associated with the @moneybag@ alias.+-- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the+-- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.+originate+  :: forall cp st vd m.+     (HasCallStack, MonadOps m)+  => OriginateData cp st vd -> m (ContractHandle cp st vd)+originate dat@OriginateData{ odContract = Contract{}, .. } = do+  addr <- originateUntyped (originateDataToUntyped dat)+  pure $ ContractHandle (pretty odName) addr++-- | A simplified version of the originate command.+-- The contract will have 0 balance.+originateSimple+  :: forall cp st vd m.+     ( HasCallStack+     , MonadOps m+     )+  => AliasHint+  -> st+  -> Contract cp st vd+  -> m (ContractHandle cp st vd)+originateSimple odName odStorage odContract = do+  let odBalance = zeroMutez+  originate OriginateData{..}++-- | Like 'originateUntypedSimple', but accepts typed contract and initial storage+-- as a Haskell value.+originateTypedSimple+  :: forall cp st vd m.+     ( HasCallStack+     , MonadOps m+     , NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd+     )+  => AliasHint -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd)+originateTypedSimple name storage contract@T.Contract{} = do+  addr <- originateUntypedSimple name (untypeHelper storage) (convertContract contract)+  pure $ ContractHandle (pretty name) addr++-- | Originate a new Michelson contract that doesn't fit into the+-- origination size limit, by executing multiple operation steps.+--+-- This operation cannot be batched (it simply may not fit).+originateLargeUntyped+  :: (HasCallStack, MonadCleveland caps m) => UntypedOriginateData -> m Address+originateLargeUntyped uod = do+  sender <- view senderL+  withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod++-- | A simplified version of the originateLargeUntyped command.+-- The contract will have 0 balance.+originateLargeUntypedSimple+  :: (HasCallStack, MonadCleveland caps m)+  => AliasHint -> U.Value -> U.Contract -> m Address+originateLargeUntypedSimple uodName uodStorage uodContract = do+  let uodBalance = zeroMutez+  originateLargeUntyped UntypedOriginateData{..}++-- | Lorentz version for large origination.+originateLarge+  :: forall param st vd m caps.+     (HasCallStack, MonadCleveland caps m)+  => OriginateData param st vd -> m (ContractHandle param st vd)+originateLarge dat@OriginateData{ odContract = Contract{}, .. } = do+  addr <- originateLargeUntyped (originateDataToUntyped dat)+  pure $ ContractHandle (pretty odName) addr++-- | A simplified version of the originateLarge command.+-- The contract will have 0 balance.+originateLargeSimple+  :: forall param st vd m caps.+     ( HasCallStack+     , MonadCleveland caps m+     )+  => AliasHint+  -> st+  -> Contract param st vd+  -> m (ContractHandle param st vd)+originateLargeSimple odName odStorage odContract = do+  let odBalance = zeroMutez+  originateLarge OriginateData{..}++-- | Base method for making a transfer.+--+-- Avoid using this method in favour of 'transferMoney' and 'call', unless+-- you need the semantics of both in one operation.+transfer :: (HasCallStack, MonadOps m) => TransferData -> m ()+transfer td = withOpsCap \opsCap ->+  runSingleOperation opsCap "transfer" (TransferOp td) \case+    TransferResult -> Just ()+    _ -> Nothing++-- | Simply transfer money to an address.+--+-- This assumes that target address is either an implicit address or has+-- a default entrypoint with a unit argument; otherwise the call fails.+transferMoney :: (HasCallStack, MonadOps m, ToAddress addr) => addr -> Mutez -> m ()+transferMoney to amount = transfer TransferData+  { tdTo = to+  , tdAmount = amount+  , tdEntrypoint = DefEpName+  , tdParameter = ()+  }++-- | Call a certain entrypoint of the given contract.+--+-- By default, the sender is the account associated with the @moneybag@ alias.+-- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the+-- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.+call+  :: forall param vd addr m epRef epArg.+     (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg, IsoValue epArg, Typeable epArg)+  => addr+  -> epRef+  -> epArg+  -> m ()+call to epRef param =+  case useHasEntrypointArg @param @epRef @epArg epRef of+    (Dict, epName) ->+      transfer TransferData+        { tdTo = toAddress $ toTAddress @param @vd @addr to+        , tdAmount = zeroMutez+        , tdEntrypoint = epName+        , tdParameter = param+        }++-- | Import an untyped contract from file.+importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract+importUntypedContract = runIO . Runtime.importUntypedContract++-- | Import a contract from file.+--+-- The compiler must be able to infer the types of parameter, storage and views.+-- In case there are no views or you don't care, you can use 'noViews'.+importContract+  :: ( HasCallStack, NiceParameterFull param, NiceStorage st+     , NiceViewsDescriptor vd, DemoteViewsDescriptor vd+     , MonadCleveland caps m+     )+  => FilePath -> m (Contract param st vd)+importContract = runIO . LorentzImport.importContract++{- | Run operations in a batch.+Best used with the @ApplicativeDo@ GHC extension.++Example:++@+{-# LANGUAGE ApplicativeDo #-}++contract <- inBatch $ do+  contract <- originate ...+  for_ [1..3] \i ->+    transfer ...+  return contract+@++Batched operations should be applied to chain faster, but note that batches have+their own limits. For instance, at the moment of writing, the gas limit on a+batch is 10x of gas limit applied to a single operation.++A context of a batch is only 'Applicative', not 'Monad'. This means that:++* Return values of one function cannot be passed to another function in the same+  batch, it can only be returned;+* Sometimes the compiler does not recognize that only 'Applicative' context is+  required, in case of any issues with that - follow the error messages.++-}+inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a+inBatch batch = do+  withCap getOpsCap \cap -> runBatched cap batch++-- | Print the given string verbatim as a comment.+-- At the moment, this is a no-op in emulator tests.+comment :: (HasCallStack, MonadCleveland caps m) => Text -> m ()+comment cmt = do+  withCap getMiscCap \cap -> cmiComment cap cmt++-- | Get the balance of the given address.+getBalance :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m Mutez+getBalance addr = do+  withCap getMiscCap \cap -> cmiGetBalance cap (toAddress addr)++-- | Get the delegate for the given contract. Fails on implicit contracts.+getDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m (Maybe KeyHash)+getDelegate addr = do+  withCap getMiscCap \cap -> cmiGetDelegate cap (toAddress addr)++-- | Register the given address as a valid delegate.+registerDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m ()+registerDelegate addr = do+  withCap getMiscCap \cap -> cmiRegisterDelegate cap (toAddress addr)++-- | Retrieve a contract's storage in its "RPC representation"+-- (i.e., all its big_maps will be replaced by big_map IDs).+--+-- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' / 'Test.Cleveland.deriveManyRPC'+-- should be used to create an RPC representation of the storage type.+--+-- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText }+-- > deriveRPC "MyStorage"+getStorage+  :: forall st addr caps m.+    (HasCallStack, MonadCleveland caps m, ToStorageType st addr, NiceUnpackedValue (AsRPC st))+  => addr+  -> m (AsRPC st)+getStorage contract = do+  someSt <- getSomeStorage contract+  case someSt ^? castTo @(AsRPC st) . value of+    Just st -> pure st+    Nothing -> failure $ unlinesF+      [ "Expected storage to be of type:"+      , indentF 2 $ build $ demote @(ToT (AsRPC st))+      , "But its type was:"+      , indentF 2 $ build $ getT someSt+      ]++-- | Retrieve a contract's full storage, including the contents of its big_maps.+--+-- This function can only be used in emulator-only tests.+getFullStorage+  :: forall st addr caps m.+    (HasCallStack, MonadEmulated caps m, ToStorageType st addr)+  => addr+  -> m st+getFullStorage contract = do+  withCap getEmulatedCap \cap -> eiGetStorage cap contract++-- | Similar to 'getStorage', but doesn't require knowing+-- the storage type in advance.+--+-- Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to+-- read data from the storage.+getSomeStorage+  :: forall addr caps m.+    (HasCallStack, MonadCleveland caps m, ToAddress addr)+  => addr+  -> m SomeAnnotatedValue+getSomeStorage contract = do+  withCap getMiscCap \cap -> cmiGetSomeStorage cap (toAddress contract)++-- | Retrieve a big_map value, given a big_map ID and a key.+-- Returns 'Nothing' when the big_map ID does not exist, or it exists but+-- does not contain the given key.+getBigMapValueMaybe+  :: forall k v caps m.+   ( HasCallStack, MonadCleveland caps m+   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+   )+  => BigMapId k v -> k -> m (Maybe v)+getBigMapValueMaybe bmId key = do+  withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key++-- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'.+getBigMapValue+  :: forall k v caps m.+   ( HasCallStack, MonadCleveland caps m+   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+   , Buildable k+   )+  => BigMapId k v -> k -> m v+getBigMapValue bmId k =+  getBigMapValueMaybe bmId k >>= \case+    Just v -> pure v+    Nothing -> failure $ unlinesF @_ @Builder+      [ "Either:"+      , "  1. A big_map with ID '" +| bmId |+ "' does not exist, or"+      , "  2. It exists, but does not contain the key '" +| k |+ "'."+      ]++-- | Retrieve all big_map values, given a big_map ID.+-- Returns 'Nothing' when the big_map ID does not exist.+getAllBigMapValuesMaybe+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+  )+  => BigMapId k v -> m (Maybe [v])+getAllBigMapValuesMaybe bmId = do+  withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId++-- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'.+getAllBigMapValues+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+  )+  => BigMapId k v -> m [v]+getAllBigMapValues bmId =+  getAllBigMapValuesMaybe bmId >>= \case+    Just vs -> pure vs+    Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist"++-- | Retrieve a big_map size, given a big_map ID.+-- Returns 'Nothing' when the big_map ID does not exist.+--+-- /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'.+getBigMapSizeMaybe+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+  )+  => BigMapId k v -> m (Maybe Natural)+getBigMapSizeMaybe bmId =+    fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId)++-- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'.+getBigMapSize+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+  )+  => BigMapId k v -> m Natural+getBigMapSize bmId =+  Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId++-- | Get the public key associated with given address.+-- Fail if given address is not an implicit account.+getPublicKey :: (HasCallStack, MonadCleveland caps m) => Address -> m PublicKey+getPublicKey addr = do+  withCap getMiscCap \cap -> cmiGetPublicKey cap addr++-- | Get the chain's @ChainId@.+getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId+getChainId = do+  withCap getMiscCap \cap -> cmiGetChainId cap++-- | Advance at least the given amount of time, or until a new block is baked,+-- whichever happens last.+--+-- On a real network, this is implemented using @threadDelay@, so it's advisable+-- to use small amounts of time only.+advanceTime+  :: forall unit caps m+  . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second)+  => Time unit -> m ()+advanceTime time = do+  withCap getMiscCap \cap -> cmiAdvanceTime cap time++-- | Wait till the provided number of levels is past.+advanceLevel+  :: forall caps m+  . (HasCallStack, MonadCleveland caps m)+  => Natural -> m ()+advanceLevel l = do+  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l)++-- | Wait till the provided level is reached.+advanceToLevel+  :: forall caps m+  . (HasCallStack, MonadCleveland caps m)+  => Natural -> m ()+advanceToLevel target = do+  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target)++-- | Get the timestamp observed by the last block to be baked.+getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp+getNow = do+  withCap getMiscCap \cap -> cmiGetNow cap++-- | Get the current level observed by the last block to be baked.+getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural+getLevel = do+  withCap getMiscCap \cap -> cmiGetLevel cap++-- | Get approximate block interval in seconds. Note, that this value+-- is minimal bound and real intervals can be larger, see+-- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function+-- for more information about block delays.+getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second)+getApproximateBlockInterval = do+  withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap++-- | Execute multiple testing scenarios independently.+--+-- * Actions performed before 'branchout' will be observed by all branches.+-- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'.+-- * Actions performed in one branch will _not_ be observed by another branch.+-- * The test succeeds IFF all branches succeed.+-- * If any branch fails, the test ends immediately and the remaining branches+--    won't be executed.+--+-- The following property holds:+--+-- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c]+--+-- The list of branches must be non-empty.+branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m ()+branchout branches = do+  caps <- ask+  let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches+  lift $ eiBranchout (getEmulatedCap caps) branches'++-- | Execute one or more actions and roll them back afterwards.+-- Actions performed in 'offshoot' will _not_ be observed by any+-- actions performed after 'offshoot'.+--+-- Similar to 'branchout', but accepts one single branch.+offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m ()+offshoot branchName branch = branchout [(branchName, branch)]++{- | Returns the result of the action with the logs it produced. Logs are messages printed by the morley instruction+[@PRINT@](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/language/morleyInstructions.md#print)++This function can be combined either with lens-based accessors or helper functions to get+more specific information about logs.++Examples:++@+(logsInfo, _) <- getMorleyLogs scenario+logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]]+logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]]+@++@+(logsInfo, _) <- getMorleyLogs scenario+collectLogs logsInfo @== MorleyLogs ["log", "log2"]+logsForAddress logsInfo @== [MorleyLogs ["log"]]+@++-}+getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a)+getMorleyLogs action = do+  caps <- ask+  let action' :: ClevelandBaseMonad caps a = runReaderT action caps+  lift $ eiGetMorleyLogs (getEmulatedCap caps) action'++-- | Version of `getMorleyLogs` for actions that don't return a result.+getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo+getMorleyLogs_ action = fst <$> getMorleyLogs action++-- | Updates voting power accessible via @VOTING_POWER@ and similar+-- instructions.+setVotingPowers :: MonadEmulated caps m => VotingPowers -> m ()+setVotingPowers vp = do+  withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp++-- | Check at runtime whether the test is being run against a network or the emulator.+--+-- Note that if you write a test suite that is executed in both modes,+-- with this function you can conditionally perform some emulation-only actions.+--+-- @+-- getRunMode >>= \case+--   NetworkMode -> do+--     ...+--   EmulationMode -> do+--     ...+-- @+getRunMode :: forall caps m. MonadCleveland caps m => m (RunMode caps)+getRunMode = pure runMode++-- | Perform an action if we are currently in emulation mode.+-- whenEmulation+whenEmulation+  :: HasClevelandCaps caps+  => (HasEmulatedCaps caps => ReaderT caps (ClevelandBaseMonad caps) ())+  -> ReaderT caps (ClevelandBaseMonad caps) ()+whenEmulation action = getRunMode >>= \case+  NetworkMode -> pass+  EmulationMode -> action++----------------------------------------------------------------------------+-- Assertions+----------------------------------------------------------------------------++-- | Fails the test with the given error message.+failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a+failure msg = do+  withCap getMiscCap \cap -> cmiFailure cap msg++-- | Fails the test with the given error message if the given condition is false.+assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()+assert b errMsg =+  unless b $ failure errMsg++-- | @x \@== expected@ fails the test if @x@ is not equal to @expected@.+(@==)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => a -- ^ The actual value.+  -> a -- ^ The expected value.+  -> m ()+actual @== expected =+  assert (actual == expected) $+    unlinesF+      [ "Failed comparison"+      , "━━ Expected (rhs) ━━"+      , build expected+      , "━━ Got (lhs) ━━"+      , build actual+      ]+infix 1 @==++-- | Fails the test if the two given values are equal.+(@/=)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => a -> a -> m ()+a @/= b =+  assert (a /= b) $+    unlinesF+      [ "The two values are equal:"+      , build a+      ]+infix 1 @/=++-- | Monadic version of '@=='.+--+-- > getBalance addr @@== 10+(@@==)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => m a -- ^ The actual value.+  -> a -- ^ The expected value.+  -> m ()+getActual @@== expected = do+  actual <- getActual+  actual @== expected+infix 1 @@==++-- | Monadic version of '@/='.+--+-- > getBalance addr @@/= 10+(@@/=)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => m a -> a -> m ()+getA @@/= b =  do+  a <- getA+  a @/= b+infix 1 @@/=++-- | Fails the test if the comparison operator fails when applied to the given arguments.+-- Prints an error message with both arguments.+--+-- Example:+--+-- > checkCompares 2 (>) 1+checkCompares+  :: forall a b caps m+   . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b)+  => a+  -> (a -> b -> Bool)+  -> b+  -> m ()+checkCompares a f b = checkComparesWith pretty a f pretty b++-- | Like 'checkCompares', but with an explicit show function.+-- This function does not have any constraint on the type parameters @a@ and @b@.+--+-- For example, to print with 'Fmt.pretty':+--+-- > checkComparesWith pretty a (<) pretty b+checkComparesWith+  :: forall a b caps m+   . (HasCallStack, MonadCleveland caps m)+  => (a -> Text)+  -> a+  -> (a -> b -> Bool)+  -> (b -> Text)+  -> b+  -> m ()+checkComparesWith showA a f showB b =+  assert (f a b) $+    unlinesF+      [ "Failed"+      , "━━ lhs ━━"+      , showA a+      , "━━ rhs ━━"+      , showB b+      ]++-- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.+evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a+evalJust err = maybe (failure err) pure++-- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.+evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b+evalRight mkErr = either (failure . mkErr) pure++----------------------------------------------------------------------------+-- Exception Handling+----------------------------------------------------------------------------++-- | Attempt to run an action and return its result or, if interpretation fails, an error.+attempt+  :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e)+  => m a -> m (Either e a)+attempt action = do+  caps <- ask+  let action' :: ClevelandBaseMonad caps a = runReaderT action caps+  lift $ cmiAttempt (getMiscCap caps) action'++-- | Asserts that a transfer should fail, and returns the exception.+catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure+catchTransferFailure action =+  attempt action >>= \case+    Left err -> return err+    Right _ -> runIO $ throwM UnexpectedSuccess++-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the exception.+--+-- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $+-- >   call contractAddr (Call @"Ep") arg+--+-- > call contractAddr (Call @"Ep") arg & expectTransferFailure+-- >   ( failedWith (customError #tag 3) &&+-- >     addressIs contractAddr+-- >   )+expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m ()+expectTransferFailure predicate act = do+  err <- catchTransferFailure act+  checkTransferFailure err predicate++-- | Check whether a given predicate holds for a given 'TransferFailure'.+checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()+checkTransferFailure err predicate =+  case go predicate of+    Success () -> pass+    Failure expectedOutcome -> failure $ unlinesF+      [ "Expected transfer to fail with an error such that:"+      , ""+      , indentF 2 $ unlinesF expectedOutcome+      , ""+      , "But these conditions were not met."+      , "Actual transfer error:"+      , indentF 2 $ build err+      ]+  where+    go :: TransferFailurePredicate -> Validation (NonEmpty Builder) ()+    go = \case+      AndPredicate ps ->+        first (fmtExpectedOutcomes "AND") (traverse_ go ps)+      OrPredicate ps ->+        case traverse_ go ps of+          Success () -> Success ()+          Failure expectedOutcomes ->+            if length expectedOutcomes == length ps+              -- If all sub-predicates failed, then this predicate failed.+              then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes+              -- If at least 1 sub-predicate succeeded, then this predicate succeeded.+              else Success ()+      TransferFailurePredicate p -> first one $ p err++    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder+    fmtExpectedOutcomes delimiter = \case+      expectedOutcome :| [] -> one expectedOutcome+      expectedOutcomes ->+        one $ unlinesF+          [ "("+          , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes+          , ")"+          ]++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant value.+expectFailedWith+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, NiceConstant err)+  => err -> m a -> m ()+expectFailedWith err = expectTransferFailure $ failedWith (constant err)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz error.+expectError+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, IsError err)+  => err -> m a -> m ()+expectError err = expectTransferFailure $ failedWith (lerror err)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom lorentz error.+expectCustomError+  :: forall arg a tag caps m+   . ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag (MText, arg)+     )+  => Label tag -> arg -> m a -> m ()+expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg)++-- | Version of 'expectCustomError' for error with @unit@ argument.+expectCustomError_+  :: ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag (MText, ())+     )+  => Label tag -> m a -> m ()+expectCustomError_ tag = expectCustomError tag ()++-- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s.+expectCustomErrorNoArg+  :: ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag MText+     )+  => Label tag -> m a -> m ()+expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz numeric error.+expectNumericError+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, IsError err)+  => ErrorTagMap -> err -> m a -> m ()+expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err)++-- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure+-- implementation), potentially thrown from the given code block.+--+-- The prefix will be put at a separate line before the main text, if text is multiline, otherwise+-- it will be separated from the main text with @: @.+--+-- This affects errors produced by functions like 'failure', 'assert', '@==', etc.+-- Errors related to events in the chain will not be touched.+--+-- Example:+--+-- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $+-- >   askContract i @@== i * 2+clarifyErrors :: forall caps m a. (MonadCleveland caps m)+              => Builder -> m a -> m a+clarifyErrors message action = do+  attempt action >>= \case+    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)+    Right val -> pure val+  where+  handle :: SomeException -> SomeException+  handle e = fromMaybe e $+        wrap testClientErrorHandler e+    <|> wrap testPureErrorHandler e+    <|> wrap withCallStackErrorHandler e++  wrap f = fmap (toException . f) . fromException++  addPrefix = pretty . nameF message . build++  testClientErrorHandler :: Client.TestError -> Client.TestError+  testClientErrorHandler = \case+    Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg++  testPureErrorHandler :: Pure.TestError -> Pure.TestError+  testPureErrorHandler = \case+    Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg+    err -> err++  withCallStackErrorHandler :: WithCallStack -> WithCallStack+  withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e++----------------------------------------------------------------------------+-- TransferFailure Predicates+----------------------------------------------------------------------------++-- | A predicate that checks whether a transfer operation failed for the expected reason.+--+-- Predicates can be combined using the '&&' and '||' operators.+data TransferFailurePredicate+  = TransferFailurePredicate+      (TransferFailure -> Validation Builder ())+      -- ^ A predicate that either returns () or, if it fails,+      -- a message explaining what the expected outcome was.+  | AndPredicate (NonEmpty TransferFailurePredicate)+  | OrPredicate (NonEmpty TransferFailurePredicate)++instance Boolean TransferFailurePredicate where+  AndPredicate l && AndPredicate r = AndPredicate $ l <> r+  AndPredicate l && r = AndPredicate $ l <> one r+  l && AndPredicate r = AndPredicate $ one l <> r+  l && r = AndPredicate $ one l <> one r++  OrPredicate l || OrPredicate r = OrPredicate $ l <> r+  OrPredicate l || r = OrPredicate $ l <> one r+  l || OrPredicate r = OrPredicate $ one l <> r+  l || r = OrPredicate $ one l <> one r++transferFailureReasonPredicate+  :: (TransferFailureReason -> Validation Builder ())+  -> TransferFailurePredicate+transferFailureReasonPredicate p = TransferFailurePredicate $+  \(TransferFailure _ reason) -> p reason++-- | Asserts that interpretation of a contract failed due to an overflow error.+shiftOverflow :: TransferFailurePredicate+shiftOverflow = transferFailureReasonPredicate \case+  ShiftOverflow -> pass+  _ -> Failure "Contract failed due to an overflow error"++-- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address.+emptyTransaction :: TransferFailurePredicate+emptyTransaction = transferFailureReasonPredicate \case+  EmptyTransaction -> pass+  _ -> Failure "Attempted to transfer 0tz to a simple address"++-- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter.+badParameter :: TransferFailurePredicate+badParameter = transferFailureReasonPredicate \case+  BadParameter -> pass+  _ -> Failure "Attempted to call a contract with a parameter of the wrong type"++-- | Asserts that interpretation of a contract failed due to gas exhaustion.+gasExhaustion :: TransferFailurePredicate+gasExhaustion = transferFailureReasonPredicate \case+  GasExhaustion -> pass+  _ -> Failure "Execution failed due to gas exhaustion"++-- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error.+--+-- This function should be used together with one of the "@FAILWITH@ constructors" (e.g. 'constant', 'customError').+failedWith :: SomeConstant -> TransferFailurePredicate+failedWith expectedFailWithVal = transferFailureReasonPredicate \case+  FailedWith (EOTVExpression actualFailWithExpr) _+    | actualFailWithExpr `isEq` expectedFailWithVal -> pass+  FailedWith (EOTVTypedValue actualFailWithVal) _+    | toExpression actualFailWithVal `isEq` expectedFailWithVal -> pass+  _ -> Failure $ "Contract failed with: " <> buildRenderDoc expectedFailWithVal+  where+    isEq :: Expression -> SomeConstant -> Bool+    isEq expr (SomeConstant (v :: T.Value t)) =+      either (const False) (== v) (fromExpression @(T.Value t) expr)++-- | Asserts that the error occurred while interpreting the contract with the given address.+addressIs+  :: ToAddress addr+  => addr -- ^ The expected address.+  -> TransferFailurePredicate+addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do+  let TransferFailure actualAddr _ = err+  when (actualAddr /= expectedAddr) $+    Failure $ "Failure occurred in contract with address: " <> build expectedAddr++----------------------------------------------------------------------------+-- 'FAILWITH' errors+----------------------------------------------------------------------------++-- | A constant michelson value that a contract threw with @FAILWITH@.+constant :: forall err. NiceConstant err => err -> SomeConstant+constant err =+  withDict (niceConstantEvi @err) $+    SomeConstant $ toVal err++-- | A lorentz error.+lerror :: forall err. IsError err => err -> SomeConstant+lerror err = errorToVal err SomeConstant++-- | A custom lorentz error.+customError+  :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg))+  => Label tag -> arg -> SomeConstant+customError tag arg =+  lerror $ CustomError tag (errorTagToMText tag, arg)++-- | A custom lorentz error with a @unit@ argument.+customError_+  :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ()))+  => Label tag -> SomeConstant+customError_ tag = customError tag ()++-- | A custom lorentz error with no argument.+customErrorNoArg+  :: (IsError (CustomError tag), MustHaveErrorArg tag MText)+  => Label tag -> SomeConstant+customErrorNoArg tag =+  lerror $ CustomError tag (errorTagToMText tag)++-- | A lorentz numeric error.+numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant+numericError tagMap err = errorToValNumeric tagMap err SomeConstant++----------------------------------------------------------------------------+-- Internal helpers+----------------------------------------------------------------------------++withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a+withCap getCap useCap = do+  cap <- asks getCap+  lift $ useCap cap++-- | Common conversion function from 'OriginateData' to 'UntypedOriginateData'+originateDataToUntyped :: OriginateData param st vd -> UntypedOriginateData+originateDataToUntyped OriginateData{ odContract = contract@Contract{}, .. } =+  UntypedOriginateData+  { uodName = odName+  , uodBalance = odBalance+  , uodStorage = untypeHelper odStorage+  , uodContract = convertContract $ toMichelsonContract contract+  }++untypeHelper :: forall st. NiceStorage st => st -> U.Value+untypeHelper = untypeValue . toVal \\ niceStorageEvi @st
+ src/Test/Cleveland/Internal/Client.hs view
@@ -0,0 +1,612 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Implementation that works with real Tezos network, it+-- talks to a Tezos node and uses @tezos-client@.++module Test.Cleveland.Internal.Client+  ( ClientM (..)+  , runClevelandT++  -- * Capability implementations+  , networkOpsImpl+  , networkMiscImpl++  -- * Internals+  , revealKeyUnlessRevealed+  , setupMoneybagAddress+  , ClientState(..)+  , TestError(..)+  , MoneybagConfigurationException (..)++  -- * Environment+  , NetworkEnv (..)++  -- * Lens for 'NetworkEnv'+  , neMorleyClientEnvL+  , neSecretKeyL+  , neMoneybagAliasL++  -- * Error types+  , InternalNetworkScenarioError(..)+  ) where++import Control.Lens+import qualified Data.Aeson.Text as J+import Data.Constraint (withDict, (\\))+import Data.Default (def)+import Data.Ratio ((%))+import qualified Data.Set as Set+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, secondsToNominalDiffTime)+import Fmt (Buildable(build), Builder, indentF, pretty, unlinesF, (+|), (|+))+import System.IO (hFlush)+import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit)+import qualified Unsafe (fromIntegral)++import Lorentz (NicePackedValue, toAddress)+import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi)+import Morley.Client+  (AddressOrAlias(..), Alias, MorleyClientEnv, disableAlphanetWarning, runMorleyClientM)+import qualified Morley.Client as Client+import Morley.Client.Logging (logInfo, logWarning)+import Morley.Client.RPC.AsRPC (AsRPC, notesAsRPC, rpcSingIEvi)+import qualified Morley.Client.RPC.Error as RPC (ClientRpcError(..), RunCodeErrors(..))+import Morley.Client.RPC.Types+  (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp),+  BlockId(..), OperationHash, OriginationScript(..),+  ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))+import Morley.Micheline+  (Expression, FromExpression(fromExpression), MichelinePrimitive(..), StringEncode(..), TezosInt64,+  TezosMutez(unTezosMutez), _ExpressionPrim, _ExpressionSeq, mpaArgsL, mpaPrimL)+import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith)+import Morley.Michelson.Typed (BigMapId, SomeAnnotatedValue(..), SomeContractAndStorage(..), toVal)+import qualified Morley.Michelson.Typed as T+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address, mkKeyAddress)+import Morley.Tezos.Core as Tezos+  (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMkMutez,+  unsafeMulMutez, unsafeSubMutez)+import Morley.Tezos.Crypto+import qualified Morley.Tezos.Crypto as Crypto+import Morley.Util.Exception+import Morley.Util.Lens (postfixLFields)+import Morley.Util.Named+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Exceptions (addCallStack)+import Test.Cleveland.Util (ceilingUnit)++data NetworkEnv = NetworkEnv+  { neMorleyClientEnv :: MorleyClientEnv+  , neSecretKey :: Maybe Crypto.SecretKey+  , neMoneybagAlias :: Alias+  }++makeLensesWith postfixLFields ''NetworkEnv+++-- | This error designates that necessary preparations for running tests+-- are not made.+data MoneybagConfigurationException+  = NoMoneybagAddress Alias+  | TwoMoneybagKeys Alias SecretKey Address+  deriving stock (Generic, Show, Eq)++instance Buildable MoneybagConfigurationException where+  build = \case+    NoMoneybagAddress alias -> unlinesF @_ @Builder+      [ "Moneybag alias is not registered in the tezos node: " <> build alias+      , ""+      , "Cleveland's network tests require a special address with plenty of XTZ for"+      , "originating contracts and performing transfers."+      , ""+      , "By default, Cleveland expects an account with the alias 'moneybag' to already exist."+      , "If no such alias exists, you can choose to either:"+      , "  * Use a different alias, supplied via '--cleveland-moneybag-alias'."+      , "  * Import a moneybag account, by supplying its secret key via '--cleveland-moneybag-secret-key'."+      ]+    TwoMoneybagKeys alias envKey existingAddress -> unlinesF @_ @Builder+      [ "Tried to import the secret key supplied via '--cleveland-moneybag-secret-key' and"+      , "associate it with the alias '" +| alias |+ "', but the alias already exists."+      , ""+      , "  --cleveland-moneybag-secret-key: " <> build envKey+      , "  Existing address             : " <> build existingAddress+      , ""+      , "Possible fix:"+      , "  * If you wish to use the existing address, please remove the '--cleveland-moneybag-secret-key' option."+      , "  * Otherwise, please supply a different alias via '--cleveland-moneybag-alias'."+      ]+++instance Exception MoneybagConfigurationException where+  displayException = pretty++data ClientState = ClientState+  { csDefaultAliasCounter :: DefaultAliasCounter+  , csRefillableAddresses :: Set Address+  , csMoneybagAddress :: Moneybag+  }++newtype ClientM a = ClientM+  { unClientM :: ReaderT (IORef ClientState) IO a+  }+  deriving newtype (Functor, Applicative, Monad, MonadIO,+                    MonadThrow, MonadCatch, MonadReader (IORef ClientState))++data InternalNetworkScenarioError = TooManyRefillIterations Word Address+  deriving stock (Show)++instance Buildable InternalNetworkScenarioError where+  build (TooManyRefillIterations iter addr) =+    "Too many (" +| iter |+ ") refill iteratons of " +| addr |+ ""++instance Exception InternalNetworkScenarioError where+  displayException = pretty++runClevelandT :: NetworkEnv -> ClevelandT ClientM a -> IO a+runClevelandT env scenario = do+  disableAlphanetWarning+  moneybagAddr <- setupMoneybagAddress env+  let caps = ClevelandCaps+        { ccSender = Sender $ unMoneybag moneybagAddr+        , ccMoneybag = moneybagAddr+        , ccMiscCap = networkMiscImpl (neMorleyClientEnv env)+        , ccOpsCap = networkOpsImpl (neMorleyClientEnv env)+        }+  ist <- newIORef ClientState+    { csDefaultAliasCounter = DefaultAliasCounter 0+    , csRefillableAddresses = Set.empty+    , csMoneybagAddress = moneybagAddr+    }+  let clientM = runReaderT scenario caps+  runReaderT (unClientM clientM) ist++-- | Initialize @moneybag@ address by given 'NetworkEnv'+setupMoneybagAddress :: NetworkEnv -> IO Moneybag+setupMoneybagAddress (NetworkEnv env envKey envAlias) = do+  storageAddress <- runMorleyClientM env $+    Client.resolveAddressMaybe (AddressAlias envAlias)+  Moneybag <$> case (envKey, storageAddress) of+    (Nothing, Just addr) -> pure addr+    (Nothing, Nothing) -> throwM $ NoMoneybagAddress envAlias+    (Just ek, Just sa)+      | mkKeyAddress (toPublic ek) == sa -> pure sa+      | otherwise -> throwM $ TwoMoneybagKeys envAlias ek sa+    (Just ek, Nothing) -> do+      runMorleyClientM env (Client.importKey False (Client.AnAlias envAlias) ek)+      return $ mkKeyAddress (toPublic ek)++-- | Implementation that works with real network and uses @tezos-node@+-- RPC and @tezos-client@.+networkOpsImpl :: MorleyClientEnv -> Sender -> ClevelandOpsImpl ClientM+networkOpsImpl env (Sender sender) =+  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler)+    ClevelandOpsImpl+    { coiRunOperationBatch = runOperationBatch env sender+    }++networkMiscImpl :: MorleyClientEnv -> ClevelandMiscImpl ClientM+networkMiscImpl env = mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)+  ClevelandMiscImpl+    { cmiRunIO = liftIO++    , cmiOriginateLargeUntyped = \sender untypedOriginateData -> do+        (_, res) <- runClientOrigination env+          sender Client.originateLargeUntypedContract untypedOriginateData+        comment $+          "Originated large smart contract " +| uodName untypedOriginateData |++          " with address " <> pretty res+        pure res++    , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM env $+        -- We don't use password protected accounts in cleveland tests+        Client.signBytes (AddressResolved signer) Nothing hash++    , cmiGenKey = \alias -> do+        aliasHint <- resolveSpecificOrDefaultAliasHint alias+        liftIO $ runMorleyClientM env . Client.genKey $ Client.AnAliasHint aliasHint++    , cmiGenFreshKey = \alias -> do+        aliasHint <- resolveSpecificOrDefaultAliasHint alias+        liftIO $ runMorleyClientM env . Client.genFreshKey $ Client.AnAliasHint aliasHint++    , cmiGetBalance = getBalanceHelper+    , cmiGetChainId = liftIO $ runMorleyClientM env Client.getChainId+    , cmiAttempt = try+    , cmiThrow = throwM+    , cmiMarkAddressRefillable = setAddressRefillable+    , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM env $ do+        alias <- Client.getAlias (Client.AddressResolved addr)+        Client.registerDelegate (Client.AnAlias alias) Nothing+    , cmiComment = comment+    , ..+    }+  where+    cmiFailure :: Builder -> ClientM a+    cmiFailure = throwM . CustomTestError . pretty++    cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v)+    cmiGetBigMapValueMaybe bigMapId k =+      liftIO . runMorleyClientM env $ Client.readBigMapValueMaybe bigMapId k++    cmiGetAllBigMapValuesMaybe :: (NiceUnpackedValue v) => BigMapId k v -> ClientM (Maybe [v])+    cmiGetAllBigMapValuesMaybe bigMapId =+      liftIO . runMorleyClientM env $ Client.readAllBigMapValuesMaybe bigMapId++    getStorageType :: Expression -> ClientM U.Ty+    getStorageType contractExpr = do+      let+        storageTypeExprMb = contractExpr ^?+          _ExpressionSeq+          . each+          . _ExpressionPrim+          . filtered (\prim -> prim ^. mpaPrimL == MichelinePrimitive "storage")+          . mpaArgsL+          . _head++      case storageTypeExprMb of+        Nothing -> cmiFailure $ unlinesF+          [ "Contract expression did not contain a 'storage' expression."+          , "Contract expression:"+          , indentF 2 $ build (J.encodeToTextBuilder contractExpr)+          ]+        Just storageTypeExpr ->+          case fromExpression @U.Ty storageTypeExpr of+            Left err -> cmiFailure $ unlinesF+              [ "'storage' expression was not a valid type expression."+              , "Storage expression:"+              , indentF 2 $ build (J.encodeToTextBuilder storageTypeExpr)+              , "Decoding error:"+              , indentF 2 $ build err+              ]+            Right storageType -> pure storageType++    cmiGetSomeStorage :: Address -> ClientM SomeAnnotatedValue+    cmiGetSomeStorage addr = do+      OriginationScript {osCode, osStorage} <- liftIO . runMorleyClientM env $ Client.getContractScript addr+      storageType <- getStorageType osCode+      T.withUType storageType \(storageNotes :: T.Notes t) -> do+        withDict (rpcSingIEvi @t) do+          case fromExpression @(T.Value (AsRPC t)) osStorage of+            Right storageValueRPC ->+              pure $ SomeAnnotatedValue (notesAsRPC storageNotes) storageValueRPC+            Left err ->+              cmiFailure $ unlinesF+                [ "Failed to decode storage expression."+                , "Storage expression:"+                , indentF 2 $ build (J.encodeToTextBuilder osStorage)+                , "Decoding error:"+                , indentF 2 $ build err+                ]++    cmiResolveAddress :: Alias -> ClientM Address+    cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias++    cmiGetPublicKey :: Address -> ClientM PublicKey+    cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved++    getBalanceHelper :: Address -> ClientM Mutez+    getBalanceHelper = liftIO . runMorleyClientM env . Client.getBalance++    cmiGetDelegate :: Address -> ClientM (Maybe KeyHash)+    cmiGetDelegate = liftIO . runMorleyClientM env . Client.getDelegate++    cmiGetNow :: ClientM Tezos.Timestamp+    cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp env++    cmiGetLevel :: ClientM Natural+    cmiGetLevel = getLastBlockLevel env++    cmiGetApproximateBlockInterval :: ClientM (Time Second)+    cmiGetApproximateBlockInterval = liftIO $ do+      pp <- runMorleyClientM env $ Client.getProtocolParameters+      return . sec $ (unStringEncode $ ppMinimalBlockDelay pp) % 1++    cmiAdvanceTime :: (KnownDivRat unit Second) => Time unit -> ClientM ()+    cmiAdvanceTime delta = do+      let+        -- Round 'delta' to the nearest second, not smaller than 'delta'.+        -- A chain's time resolution is never smaller than a second,+        -- so if 'delta' is 0.1s, we actually need to wait at least 1s.+        deltaSec :: Time Second+        deltaSec = ceilingUnit $ toUnit @Second delta++        deltaSec' :: NominalDiffTime+        deltaSec' = secondsToNominalDiffTime $ toNum @Second deltaSec+      t0 <- getLastBlockTimestamp env+      threadDelay deltaSec+      let+        go :: ClientM ()+        go = do+          now <- getLastBlockTimestamp env+          if (now `diffUTCTime` t0) >= deltaSec'+            then pass+            else threadDelay (sec 1) >> go+      go++    cmiAdvanceToLevel :: (Natural -> Natural) -> ClientM ()+    cmiAdvanceToLevel targetLevelFn = do+      lastLevel <- getLastBlockLevel env+      let targetLevel = max (targetLevelFn lastLevel) lastLevel+      let skippedLevels = targetLevel - lastLevel+      -- In case we need to skip more than one level we'll jump ahead for+      -- 'cmiGetApproximateBlockInterval' for 'skippedLevels - 1' times.+      -- This way we are sure we won't end up in the middle (or towards the end)+      -- of the target level.+      when (skippedLevels > 0) $ do+        when (skippedLevels > 1) $ do+          minBlockInterval <- cmiGetApproximateBlockInterval+          let waitTime = (skippedLevels - 1) * toNum @Second minBlockInterval+          threadDelay . sec $ waitTime % 1+        -- A chain's time resolution is never smaller than a second, so with (less+        -- than) a level to go we can wait for 1s in loop until we reach the target.+        let go :: ClientM ()+            go = do+              curLevel <- cmiGetLevel+              when (targetLevel > curLevel) $ threadDelay (sec 1) >> go+        go++comment :: Text -> ClientM ()+comment msg = liftIO $ putTextLn msg >> hFlush stdout++getAlias :: MorleyClientEnv -> Address -> ClientM Alias+getAlias env = liftIO . runMorleyClientM env . Client.getAlias . AddressResolved++getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime+getLastBlockTimestamp env = liftIO $+  bhnhTimestamp . bcHeader <$> runMorleyClientM env (Client.getBlockConstants HeadId)++getLastBlockLevel :: MorleyClientEnv -> ClientM Natural+getLastBlockLevel env = do+  bc <- liftIO $ runMorleyClientM env (Client.getBlockConstants HeadId)+  pure . Unsafe.fromIntegral @Int64 @Natural . bhnhLevel $ bcHeader bc++runOperationBatch :: MorleyClientEnv -> Address -> [BaseOperationData] -> ClientM [BaseOperationResult]+runOperationBatch env sender ops = do+  istRef <- ask+  ClientState{csMoneybagAddress=Moneybag moneybag} <- readIORef istRef+  -- Note that tezos key reveal operation cost an additional fee+  -- so that's why we reveal keys in origination and transaction+  -- rather than doing it before scenario execution+  liftIO $ revealKeyUnlessRevealed env sender++  ops' <- forM ops \case+    OriginateOp uod ->+      Right <$> convertOriginateUntypedData uod+    TransferOp td ->+      pure . Left $ convertTransferData td++  let refill :: Word -> Client.MorleyClientM Word+      refill iter = do+        void $ dryRunOperations (AddressResolved sender) ops'+        pure iter+        `catch` \errs -> do+          when (iter > 3) $ throwM $ TooManyRefillIterations iter sender+          realBalance <- Client.getBalance sender+          let handleRunErrors errs'+                | Just (required, balance) <- findBalanceTooLow errs' = do+                    logInfo $ sender |+ " balance of " +| realBalance |+ " \n\+                              \is too low, need " +| required |+ ", but got " +| balance |+ ""+                    let reportedDifference = unsafeSubMutez required balance+                        -- required >= balance should always be true if we got 'BalanceTooLow'+                    if iter == 0+                    -- on first iteration, we dry-run the transaction as moneybag (if possible)+                    -- and esitmate the required balance that way;+                    then approximateRequired realBalance+                            `catch` \(_ :: SomeException) -> pure reportedDifference+                    -- on subsequent iterations (which run only if the first+                    -- wasn't enough), we rely on the reported `required` and `balance`,+                    -- NOTE: BalanceTooLow can be thrown either before fees are subtracted, or after.+                    -- In the former case, (required - balance == transfer_amount - real_balance)+                    -- In the latter case, (required - balance == transfer_amount - real_balance - fees)+                    -- Notice that fees are only included if real_balance >= transfer_amount.+                    -- Consequently, if transfer_amount > real_balance AND+                    -- transfer_amount + fees > real_balance + minimalMutez, the amount we transfer here+                    -- will be insufficient. TL;DR, it doesn't work for large transfer_amounts.+                    -- For batched transfers, this gets a bit more complicated, but the same principle+                    -- applies; unless total fees can exceed minimalMutez, or total transfer_amount+                    -- is large, it should work without looping.+                    else pure reportedDifference+                | findCantPayStorageFee errs' = do+                    logInfo $ sender |+ " balance of " +| realBalance |+ "\n\+                              \ is too low to pay storage fee"+                    -- since no required balance is reported, there is no choice+                    approximateRequired realBalance+                      -- if running as moneybag failed for some reason, just throw in some tez+                      -- and hope for the best+                      `catch` \(_ :: SomeException) -> pure minimalMutez+                | otherwise = throwM errs+          amount <- max minimalMutez . addSafetyMutez <$> if+            | Just (Client.UnexpectedRunErrors err) <- fromException errs -> handleRunErrors err+            | Just (RPC.RunCodeErrors err) <- fromException errs -> handleRunErrors err+            | otherwise -> throwM errs+          logInfo $ "Will transfer " +| amount |+ " from " +| moneybag |+ ""+          void $ Client.lTransfer moneybag sender amount U.DefEpName () Nothing+          refill (iter + 1) -- loop+      addSafetyMutez x = fromMaybe x $ addMutez x safetyMutez+      minimalMutez = unsafeMkMutez 5e5+      safetyMutez = unsafeMkMutez 100+      safetyStorage = 20+      approximateRequired balance = do+        -- dry-run as moneybag and estimate cost+burn+fees+        (appliedResults, fees) <- unzip <$> dryRunOperations (AddressResolved moneybag) ops'+        ProtocolParameters{..} <- Client.getProtocolParameters+        -- uses quite a bit of unsafe mutez arithmetic, but arguably+        -- if we end up running into overflow while computing the+        -- required balance, then we couldn't run these operations+        -- anyway.+        let totalFees = unsafeSumMutez fees+            unsafeSumMutez = foldr unsafeAddMutez zeroMutez+            zeroMutez = unsafeMkMutez 0+            originationSz = Unsafe.fromIntegral @Int @Natural ppOriginationSize+            (opsSum, originationSize) = bimap unsafeSumMutez sum . unzip+              $ map opcostAndOriginationCount ops+            costPerByte = unTezosMutez ppCostPerByte+            opcostAndOriginationCount = \case+              OriginateOp uod -> (uodBalance uod, originationSz)+              TransferOp td -> (tdAmount td, 0)+            storageDiff AppliedResult{..} = safetyStorage + Unsafe.fromIntegral @TezosInt64 @Natural arPaidStorageDiff+            storageBurnInBytes = originationSize + sum (map storageDiff appliedResults)+            storageBurnInMutez = unsafeMulMutez costPerByte storageBurnInBytes+            required = opsSum `unsafeAddMutez` totalFees `unsafeAddMutez` storageBurnInMutez+        logInfo $ "estimated amount needed is " +| required |+ ", but got " +| balance |+ "\n\+                  \Storage size: " +| storageBurnInBytes |+ "; Operations cost: " +| opsSum |+ "\n\+                  \Fees: " +| totalFees |+ "; Storage burn cost: " +| storageBurnInMutez |+ ""+        pure $ fromMaybe zeroMutez $ subMutez required balance++  refillable <- isAddressRefillable sender+  results <- liftIO $ runMorleyClientM env $ do+    when refillable $ do+      tookIters <- refill 0+      when (tookIters > 1) $ logWarning $+        "Refill of " +| sender |+ " took " +| tookIters |+ " iterations."+    snd <$> Client.runOperations (AddressResolved sender) ops'++  let results' = results <&> \case+        Left () ->+          TransferResult+        Right addr ->+          OriginateResult addr++  forM_ results' $ \case+    OriginateResult addr -> do+      alias <- getAlias env addr+      comment $ "Originated smart contract '" +| alias |++        "' with address " <> pretty addr+    _ -> pass++  return results'++dryRunOperations :: AddressOrAlias+                  -> [Either Client.TransactionData Client.OriginationData]+                  -> Client.MorleyClientM [(AppliedResult, Mutez)]+dryRunOperations s = \case+  [] -> return []+  (x:xs) -> toList . map (second unTezosMutez) <$> Client.dryRunOperationsNonEmpty s (x :| xs)++findBalanceTooLow :: [Client.RunError] -> Maybe (Mutez, Mutez)+-- we really shouldn't get several errors of the same type here, so find only the first one+findBalanceTooLow+  (Client.BalanceTooLow (N balance) (N required):_)+  = Just (required, balance)+findBalanceTooLow (_:xs) = findBalanceTooLow xs+findBalanceTooLow [] = Nothing++findCantPayStorageFee :: [Client.RunError] -> Bool+-- we really shouldn't get several errors of the same type here, so find only the first one+findCantPayStorageFee+  (Client.CantPayStorageFee:_)+  = True+findCantPayStorageFee (_:xs) = findCantPayStorageFee xs+findCantPayStorageFee [] = False++exceptionToTransferFailure :: RPC.ClientRpcError -> ClientM TransferFailure+exceptionToTransferFailure = \case+  RPC.ContractFailed addr expr -> return $ TransferFailure addr $ FailedWith (EOTVExpression expr) Nothing+  RPC.BadParameter addr _ -> return $ TransferFailure addr BadParameter+  RPC.EmptyTransaction addr -> return $ TransferFailure addr EmptyTransaction+  RPC.ShiftOverflow addr -> return $ TransferFailure addr ShiftOverflow+  RPC.GasExhaustion addr -> return $ TransferFailure addr GasExhaustion+  internalError -> throwM internalError++exceptionHandler :: ClientM a -> ClientM a+exceptionHandler action = try action >>= \case+  Left err -> exceptionToTransferFailure err >>= throwM+  Right res -> return res++runClientOrigination+  :: MorleyClientEnv+  -> Sender+  -> (  Bool+      -> AliasHint+      -> AddressOrAlias+      -> Mutez+      -> U.Contract+      -> U.Value+      -> Maybe Mutez+      -> Client.MorleyClientM (OperationHash, Address)+      )+  -> UntypedOriginateData+  -> ClientM (OperationHash, Address)+runClientOrigination env (Sender sender) mkScenario (UntypedOriginateData{..}) = do+  let originationScenario =+        mkScenario True uodName (AddressResolved sender)+          uodBalance uodContract uodStorage Nothing+  -- Note that tezos key reveal operation cost an additional fee+  -- so that's why we reveal keys in origination and transaction+  -- rather than doing it before scenario execution+  liftIO $ do+    revealKeyUnlessRevealed env sender+    runMorleyClientM env originationScenario++resolveSpecificOrDefaultAliasHint :: SpecificOrDefaultAliasHint -> ClientM AliasHint+resolveSpecificOrDefaultAliasHint (SpecificAliasHint aliasHint) =+  return aliasHint+resolveSpecificOrDefaultAliasHint (DefaultAliasHint) = do+  stateRef <- ask+  ist@ClientState{csDefaultAliasCounter=DefaultAliasCounter counter} <- readIORef stateRef+  writeIORef stateRef ist{ csDefaultAliasCounter = DefaultAliasCounter $ counter + 1 }+  return $ mkDefaultAlias counter++setAddressRefillable :: Address -> ClientM ()+setAddressRefillable addr = do+  stRef <- ask+  modifyIORef stRef $ \st@ClientState{..} ->+    st{csRefillableAddresses=Set.insert addr csRefillableAddresses}++isAddressRefillable :: Address -> ClientM Bool+isAddressRefillable addr = do+  stRef <- ask+  Set.member addr . csRefillableAddresses <$> readIORef stRef++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++convertOriginateUntypedData+  :: (MonadThrow m)+  => UntypedOriginateData -> m Client.OriginationData+convertOriginateUntypedData UntypedOriginateData{..} = do+  SomeContractAndStorage contract storage <-+    throwLeft . pure $ typeCheckingWith def $+      typeCheckContractAndStorage uodContract uodStorage+  return Client.OriginationData+    { odReplaceExisting = True+    , odName = uodName+    , odBalance = uodBalance+    , odContract = contract+    , odStorage = storage+    , odMbFee = Nothing+    }++convertTransferData+  :: TransferData -> Client.TransactionData+convertTransferData TransferData{ tdParameter = param :: p, ..} =+  Client.TransactionData Client.TD+    { tdReceiver = toAddress tdTo+    , tdAmount = tdAmount+    , tdEpName = tdEntrypoint+    , tdParam = toVal param+    , tdMbFee = Nothing+    } \\ niceParameterEvi @p++-- | Runs 'Client.revealKeyUnlessRevealed' with given client environment.+revealKeyUnlessRevealed :: MorleyClientEnv -> Address -> IO ()+revealKeyUnlessRevealed env addr = runMorleyClientM env $+  -- We don't use password protected accounts in cleveland.+  Client.revealKeyUnlessRevealed addr Nothing++----------------------------------------------------------------------------+-- Validation+----------------------------------------------------------------------------++-- | Signals an assertion failure during the execution of an action.+newtype TestError+  = CustomTestError Text+  deriving stock Show++instance Exception TestError where+  displayException = pretty++instance Buildable TestError where+  build (CustomTestError msg) = build msg
+ src/Test/Cleveland/Internal/Exceptions.hs view
@@ -0,0 +1,88 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module defines common exception types and exception-related functions+-- used throughout the "Test.Cleveland" modules.+module Test.Cleveland.Internal.Exceptions+  ( WithCallStack(..)+  , addCallStack+  , throwWithCallStack+  , tryWithCallStack+  , catchWithCallStack+  ) where++import Data.Typeable (cast)+import Fmt (Buildable(..), pretty, unlinesF)++----------------------------------------------------------------------------+-- WithCallStack+----------------------------------------------------------------------------++-- | Wraps an exception and adds some callstack information.+data WithCallStack where+  WithCallStack :: CallStack -> SomeException -> WithCallStack++deriving stock instance Show WithCallStack++instance Buildable WithCallStack where+  build (WithCallStack cstack e) = unlinesF+    [ prettyCallStack cstack+    , displayException e+    ]++instance Exception WithCallStack where+  displayException = pretty++-- | Wrap any exceptions thrown by some monadic action with 'WithCallStack'.+--+-- If the action throws an exception already wrapped in 'WithCallStack',+-- that callstack will be overriden with the current one.+addCallStack :: forall m a. (HasCallStack, MonadCatch m) => m a -> m a+addCallStack ma =+  ma `catch` \se@(SomeException ex) ->+    case fromException @WithCallStack se of+      Just (WithCallStack _ innerEx) -> throwWithCallStack callStack innerEx+      Nothing -> throwWithCallStack callStack ex++throwWithCallStack :: forall e a m. (MonadThrow m, Exception e) => CallStack -> e -> m a+throwWithCallStack cstack ex = throwM (WithCallStack cstack (toException ex))+++-- | Similar to 'catch', but also catches exceptions of type @e@ wrapped in 'WithCallStack'.+catchWithCallStack+  :: forall e a m. (Exception e, MonadCatch m)+  => m a -> (Maybe CallStack -> e -> m a) -> m a+catchWithCallStack ma f =+  ma `catch` \(se :: SomeException) ->+    case fromExceptionWithCallStack @e se of+      Just (cstackMb, e) -> f cstackMb e+      Nothing -> throwM se++-- | Attempts to run the given action.+--+-- If it:+--+-- * suceeds, the value will be returned in a 'Right'.+-- * throws an exception of the given type @e@ (or an exception of+--   type @e@ wrapped in 'WithCallStack'), it will be returned in a 'Left'.+-- * throws an exception of any other type, it'll be rethrown+--   (retaining the original callstack, if any).+tryWithCallStack :: forall e a m. (MonadCatch m, Exception e) => m a -> m (Either (Maybe CallStack, e) a)+tryWithCallStack ma =+  try @_ @SomeException ma >>= \case+    Right a -> pure (Right a)+    Left se ->+      case fromExceptionWithCallStack @e se of+        Just e -> pure (Left e)+        Nothing -> throwM se++fromExceptionWithCallStack :: forall e. Exception e => SomeException -> Maybe (Maybe CallStack, e)+fromExceptionWithCallStack se =+  (do+    WithCallStack cstack e <- fromException @WithCallStack se+    e' <- cast @_ @e e+    Just (Just cstack, e')+  )+  <|>+  (fromException @e se <&> (Nothing,))
+ src/Test/Cleveland/Internal/Hedgehog.hs view
@@ -0,0 +1,66 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Hedgehog-related helpers+module Test.Cleveland.Internal.Hedgehog+  ( MonadTest (..)+  , evalIO+  , testScenarioProps+  ) where++import Data.Char (isSpace)+import Data.Coerce (coerce)+import Data.List (dropWhileEnd)+import qualified Data.String as String+import Data.Typeable (typeOf)+import GHC.Stack+  (SrcLoc(SrcLoc), srcLocEndCol, srcLocEndLine, srcLocFile, srcLocStartCol, srcLocStartLine)+import Hedgehog.Internal.Exception (tryAll)+import Hedgehog.Internal.Property hiding (evalIO)+import Hedgehog.Internal.Source (ColumnNo(..), LineNo(..), Span(..))++import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Pure+import Test.Cleveland.Internal.Scenario++-- | Run an 'Scenario' via the "Morley.Michelson.Runtime" emulator,+-- inside an @hedgehog@ property.+testScenarioProps :: (HasCallStack, MonadIO m, MonadTest m) => Scenario PureM -> m ()+testScenarioProps = evalIO . \case+  ScenarioCleveland s -> runClevelandT moneybagAlias s+  ScenarioEmulated s -> runEmulatedT moneybagAlias s++evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a+evalIO m = either (withFrozenCallStack failWithException) pure =<< liftIO (tryAll m)++failWithException :: (HasCallStack, MonadTest m) => SomeException -> m a+failWithException e =+  case fromException @WithCallStack e of+    Just (WithCallStack cs _) -> failWithCallStack cs message+    _                         -> failWithCallStack callStack message+  where+    message = formatException e++failWithCallStack :: (MonadTest m) => CallStack -> String -> m a+failWithCallStack cs message = liftTest $ mkTest+  (Left $ Failure (extractSpan cs) message Nothing, mempty)++formatException :: SomeException -> String+formatException (SomeException e) =+  String.unlines [+    "━━━ Exception (" <> show (typeOf e) <> ") ━━━"+    , dropWhileEnd isSpace (displayException e)+  ]++extractSpan :: CallStack -> Maybe Span+extractSpan cs =+  nonEmpty (getCallStack cs)+    <&> last+    <&> \(_, SrcLoc{..}) ->+      Span+        srcLocFile+        (coerce srcLocStartLine)+        (coerce srcLocStartCol)+        (coerce srcLocEndLine)+        (coerce srcLocEndCol)
+ src/Test/Cleveland/Internal/Pure.hs view
@@ -0,0 +1,607 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Integration with integrational testing engine (pun intended).+module Test.Cleveland.Internal.Pure+  ( PureM(..)+  , runClevelandT+  , runEmulatedT++  -- * Capability implementations+  , PureState+  , TestError(..)+  , emulatedImpl+  , clevelandOpsImpl+  , clevelandMiscImpl++  -- * Initial environment for Emulated tests+  , initEnv++  -- * Support functions+  , failedInsideBranch+  , moneybagAlias+  , emptyScenarioBranch++  -- * Optics+  , psAliases+  , psDefaultAliasesCounter+  , psRefillableAddresses+  , psNow+  , psLevel+  , psGState+  , psExecutorResult+  , psContractsNames+  ) where++import Control.Lens (assign, makeLenses, modifying, to, (%=), (.=))+import Control.Monad.Catch.Pure (CatchT, runCatchT)+import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell)+import Data.Constraint (Dict(..), withDict, (\\))+import Data.Default (def)+import qualified Data.Map as Map+import Data.Monoid (Ap(..))+import qualified Data.Set as Set+import Data.Type.Equality (type (:~:)(Refl))+import Fmt (Buildable(..), Builder, indentF, pretty, unlinesF, (+|), (|+))+import Time (Second, toNum, toUnit)++import Lorentz (Mutez, NiceComparable, pattern DefEpName)+import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg)+import qualified Lorentz.Value as L (TAddress(..), ToTAddress(..))+import Morley.Client (Alias, mkAlias)+import Morley.Client.RPC.AsRPC (notesAsRPC, rpcStorageScopeEvi, valueAsRPC)+import Morley.Client.TezosClient.Types (unsafeCoerceAliasHintToAlias, unsafeGetAliasHintText)+import Morley.Michelson.Interpret+  (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..))+import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer)+import qualified Morley.Michelson.Runtime as Runtime (ExecutorOp(..))+import Morley.Michelson.Runtime.Dummy (dummyLevel, dummyMaxSteps, dummyNow, dummyOrigination)+import Morley.Michelson.Runtime.GState+  (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL,+  gsVotingPowersL, initGState)+import Morley.Michelson.TypeCheck (TCError(..), typeCheckContractAndStorage, typeCheckingWith)+import Morley.Michelson.Typed+  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), ToT, Value, Value'(..), castM,+  dfsFoldMapValue, fromVal, requireEq, toVal)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..))+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address, detGenKeyAddress)+import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez)+import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic)+import Morley.Util.Named++import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Exceptions (addCallStack, catchWithCallStack, throwWithCallStack)+import Test.Cleveland.Lorentz+import Test.Cleveland.Util (ceilingUnit)++data PureState = PureState+  { _psAliases :: Aliases+  , _psDefaultAliasesCounter :: DefaultAliasCounter+  , _psRefillableAddresses :: Set Address+  , _psNow :: Timestamp+  , _psLevel :: Natural+  , _psGState :: GState+  , _psExecutorResult :: Maybe ExecutorRes+  -- ^ Store the most recent result of interpreted operations.+  , _psContractsNames :: Map Address Text+  -- ^ Map from contracts addresses to human-readable names.+  }++instance MonadState PureState PureM where+  get = ask >>= readIORef+  put = (ask >>=) . flip writeIORef++data AddressName = AddressName (Maybe Text) Address deriving stock (Show)++newtype PureM a = PureM+  { unPureM :: ReaderT (IORef PureState) (CatchT (WriterT LogsInfo IO)) a+  }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,+                    MonadReader (IORef PureState), MonadWriter LogsInfo)++type Aliases = Map Alias AliasData++-- | Datatype to store alias data, we store optional 'SecretKey' in addition+-- to 'Address' in order to support bytes signing.+data AliasData = AliasData+  { adAddress :: Address+  , adMbSecretKey :: Maybe SecretKey+  }++data TestError+  = UnexpectedTypeCheckError TCError+  | UnexpectedStorageType T.T T.T+  | UnexpectedBigMapKeyType T.T T.T+  | UnexpectedBigMapValueType T.T T.T+  | CustomTestError Text+  deriving stock Show++makeLenses ''PureState++instance Buildable AddressName where+  build (AddressName mbName addr) =+    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName++instance Buildable TestError where+  build (UnexpectedTypeCheckError tcErr) =+    "Unexpected type check error. Reason: " +| tcErr |+ ""+  build (UnexpectedStorageType actualT expectedT) = unlinesF+    [ "Expected storage to be of type:"+    , indentF 2 $ build $ expectedT+    , "But its type was:"+    , indentF 2 $ build $ actualT+    ]+  build (UnexpectedBigMapKeyType actualT expectedT) = unlinesF+    [ "Expected big_map's key type to be: " <> build expectedT+    , "But its type was:                  " <> build actualT+    ]+  build (UnexpectedBigMapValueType actualT expectedT) = unlinesF+    [ "Expected big_map's value type to be:"+    , indentF 2 $ build expectedT+    , "But its type was:"+    , indentF 2 $ build actualT+    ]+  build (CustomTestError msg) = pretty msg++instance Exception TestError where+  displayException = pretty++-- In this implementation we do not prefix aliases, so 'Alias' and 'AliasHint'+-- are identical and conversions between them are safe.+hintToAlias :: AliasHint -> Alias+hintToAlias = unsafeCoerceAliasHintToAlias++moneybagAlias :: Alias+moneybagAlias = mkAlias "moneybag"++runEmulatedT :: Alias -> EmulatedT PureM a -> IO a+runEmulatedT moneybagAlias' scenario =+  runClevelandT moneybagAlias' do+    clevelandCaps <- ask+    let emulatedCaps = EmulatedCaps emulatedImpl clevelandCaps+    lift $ runReaderT scenario emulatedCaps++runClevelandT :: Alias -> ClevelandT PureM a -> IO a+runClevelandT moneybagAlias' scenario = do+  let caps = ClevelandCaps+        { ccSender = Sender genesisAddress+        , ccMoneybag = Moneybag genesisAddress+        , ccMiscCap = clevelandMiscImpl+        , ccOpsCap = clevelandOpsImpl+        }+  let pureM = runReaderT scenario caps+  env <- newIORef (initEnv moneybagAlias')+  (res, _logs) <- runWriterT $ runCatchT $ runReaderT (unPureM pureM) env+  either throwM pure $ res++emulatedImpl :: EmulatedImpl PureM+emulatedImpl =+  EmulatedImpl+    { eiBranchout = \(scenarios :: [(Text, PureM ())]) ->+        forM_ scenarios $ \(name, scenario) -> do+          aliasesState <- get+          newRef <- newIORef aliasesState+          local (\_ -> newRef) scenario `catchWithCallStack` \originalCallStackMb err ->+            maybe throwM throwWithCallStack originalCallStackMb $ failedInsideBranch name err+      , eiGetStorage = addCallStack . exceptionHandler . getStorageImpl+    , eiGetMorleyLogs = getMorleyLogsImpl+    , eiSetVotingPowers = assign (psGState . gsVotingPowersL)+    }++clevelandOpsImpl :: Sender -> ClevelandOpsImpl PureM+clevelandOpsImpl (Sender sender) =+  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler)+    ClevelandOpsImpl+    { coiRunOperationBatch = mapM \case+        OriginateOp UntypedOriginateData{..} -> do+          ref <- originate uodContract (pretty uodName) uodStorage uodBalance+          OriginateResult <$> saveAlias uodName (toAddress ref) Nothing+        TransferOp TransferData{..} -> do+          let fromAddr = #from :! sender+          let toAddr = #to :! toAddress tdTo+          refillable <- isAddressRefillable sender+          when refillable $ do+            balance <- getBalance sender+            when (balance < tdAmount) $ do+              let moneybag = #from :! genesisAddress+                  toSender = #to :! sender+              transfer @() moneybag toSender (unsafeSubMutez tdAmount balance)+                (TrustEpName DefEpName) ()+          -- Here @toAddr@ is 'Address', so we can not check anything+          -- about it and assume that entrypoint is correct. We pass+          -- unit as contract parameter because it won't be checked+          -- anyway.+          transfer @() fromAddr toAddr tdAmount+            (TrustEpName tdEntrypoint) tdParameter++          return TransferResult+    }++clevelandMiscImpl :: ClevelandMiscImpl PureM+clevelandMiscImpl =+  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)+    ClevelandMiscImpl+    { cmiRunIO = \action -> liftIO (try action) >>= \case+        Right res -> pure res+        Left (err :: SomeException) -> throwM err++    , cmiResolveAddress = resolve++    , cmiSignBytes = \bs addr -> do+        -- TODO [#248]: make sure this performs fast+        alias <- getAlias addr+        aliases <- use psAliases+        let mbMbSk = Map.lookup alias aliases+        mbSk <- maybe (unknownAlias alias) (pure . adMbSecretKey) mbMbSk+        case mbSk of+          Nothing ->+            throwM . CustomTestError .+            mappend "Given address doesn't have known associated secret key: " . show $ alias+          Just sk -> liftIO $ sign sk bs++    , cmiGenKey = \alias -> do+      aliasHint <- resolveSpecificOrDefaultAliasHint alias+      smartGenKey Nothing aliasHint++    , cmiGenFreshKey =+        \alias -> do+          aliasHint <- resolveSpecificOrDefaultAliasHint alias+          aliases <- use psAliases+          let mbSk = Map.lookup (hintToAlias aliasHint) aliases+          smartGenKey (adAddress <$> mbSk) aliasHint++    , cmiOriginateLargeUntyped = originateUntyped++    -- Comments are not supported by integrational testing engine (yet).+    , cmiComment = const pass+    , cmiGetPublicKey = \addr -> do+        aliases <- use psAliases+        let mbAliasInfo = fmap snd $ find (\(_, AliasData addr' _) -> addr == addr') (Map.toList aliases)+        aliasInfo <- maybe (unknownAddress addr) pure mbAliasInfo+        case adMbSecretKey aliasInfo of+          Nothing ->+            throwM . CustomTestError .+            mappend "Given address doesn't have known associated public key: " . show $ addr+          Just sk -> pure $ toPublic sk+    , cmiGetDelegate = \addr -> do+        ContractState _ _ _ delegate <- contractStorage addr+        pure delegate+    , cmiRegisterDelegate = const pass+    , cmiGetChainId = use $ psGState . gsChainIdL+    , cmiAdvanceTime = \time -> do+        modifying psNow . flip timestampPlusSeconds $+          toNum @Second @Integer $ ceilingUnit $ toUnit @Second time++    , cmiAdvanceToLevel = \fn ->+        -- do not go back in levels+        modifying psLevel (\cl -> max (fn cl) cl)++    , cmiGetNow = use psNow+    , cmiGetLevel = use psLevel+    , cmiGetApproximateBlockInterval = pure $ sec 1+    , cmiFailure = throwM . CustomTestError . pretty+    , cmiAttempt = try+    , cmiThrow = throwM+    , cmiMarkAddressRefillable = setAddressRefillable+    , cmiGetBalance = getBalance+    , ..+    }+  where+    setAddressRefillable addr = psRefillableAddresses %= Set.insert addr++    originateUntyped :: Sender -> UntypedOriginateData -> PureM Address+    originateUntyped _ UntypedOriginateData {..} = do+      ref <- originate uodContract (pretty uodName) uodStorage uodBalance+      saveAlias uodName (toAddress ref) Nothing++    cmiGetBigMapValueMaybe+      :: forall k v.+         (NiceComparable k, IsoValue v)+      => BigMapId k v+      -> k+      -> PureM (Maybe v)+    cmiGetBigMapValueMaybe bmId k = do+      mbBigMap <- findBigMapById bmId+      case mbBigMap of+        Nothing      -> pure Nothing+        Just bigMap  -> pure $ fromVal @v <$> Map.lookup (toVal k) bigMap++    cmiGetAllBigMapValuesMaybe+      :: forall k v.+         (NiceComparable k, IsoValue v)+      => BigMapId k v+      -> PureM (Maybe [v])+    cmiGetAllBigMapValuesMaybe bmId = do+      mbBigMap <- findBigMapById bmId+      case mbBigMap of+        Nothing     -> pure Nothing+        Just bigMap -> pure $ Just $ fromVal @v <$> Map.elems bigMap++    -- | Traverse storage values of all contracts and looks for a big_map with the given ID.+    -- If multiple big_maps with the given ID are found, it fails with error.+    findBigMapById+      :: forall k v.+         (NiceComparable k, IsoValue v)+      => BigMapId k v+      -> PureM (Maybe (Map (Value (ToT k)) (Value (ToT v))))+    findBigMapById (BigMapId bigMapId) = do+      addresses <- use $ psGState . gsAddressesL . to Map.elems++      let Ap result =+            flip foldMap addresses \case+              ASContract ContractState{csStorage} ->+                findBigMapInStorage csStorage bigMapId+              ASSimple {} -> Ap $ Right []++      case result of+        -- The RPC does not distinguish between "the bigmap does not exist"+        -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here.+        -- We simply return `Nothing` in both cases.+        Right [] -> pure Nothing+        Right [bigMap] -> pure $ Just bigMap+        Right bigMaps ->+          error $ pretty $ unlinesF @_ @Builder+            [ "Expected all big_maps to have unique IDs, but found " +| length bigMaps |+ " big_maps with the ID " +| bigMapId |+ "."+            , "This is most likely a bug."+            ]+        Left (err :: TestError) -> throwM err++    -- | Traverse a storage value and looks for a big_map with the given ID.+    -- If multiple big_maps with the given ID are found, they'll all be returned.+    findBigMapInStorage+      :: forall k v st. (SingI k, SingI v)+      => Value st -> Natural -> Ap (Either TestError) [Map (Value k) (Value v)]+    findBigMapInStorage storage bigMapId =+      dfsFoldMapValue+        (\case+            VBigMap (Just bigMapId') (bigMap :: Map (Value k') (Value v'))+              | bigMapId == bigMapId' -> do+                  Refl <- requireEq @k' @k (Ap . Left ... UnexpectedBigMapKeyType)+                  Refl <- requireEq @v' @v (Ap . Left ... UnexpectedBigMapValueType)+                  pure [bigMap]+            _ -> Ap $ Right []+        )+        storage++    -- | In a real chain, when we retrieve a contract's storage via the Tezos RPC,+    -- the storage expression will have all the big_maps replaced with their respective big_map IDs.+    --+    -- Here, we mimic the RPC's behaviour.+    --+    -- We expect all big_maps in the storage to already have an ID.+    -- IDs are assigned to big_maps by the interpreter/runtime when:+    --   * A contract with big_maps in its storage is originated+    --   * A transfer is made and the parameter contains big_maps+    --   * A contract's code is run and it calls `EMPTY_BIG_MAP`, `DUP` or `DUP n`.+    cmiGetSomeStorage :: Address -> PureM SomeAnnotatedValue+    cmiGetSomeStorage addr = do+      ContractState _ contract (storage :: Value t) _ <- contractStorage addr+      pure $+        SomeAnnotatedValue+          (notesAsRPC $ T.cStoreNotes contract)+          (valueAsRPC storage)+          \\ rpcStorageScopeEvi @t++    getAlias :: Address -> PureM Alias+    getAlias addr = do+      aliases <- use psAliases+      let maybeAlias = (fmap fst . find (\(_, AliasData addr' _) -> addr == addr') . Map.toList) aliases+      maybe (unknownAddress addr) pure maybeAlias++    -- Generate a fresh address which was never generated for given alias.+    -- If the address is not saved, we use the alias as its seed.+    -- Otherwise we concatenate the alias with the saved address.+    smartGenKey :: Maybe Address -> AliasHint -> PureM Address+    smartGenKey existingAddr aliasHint@(unsafeGetAliasHintText -> aliasTxt) =+      let+        seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr+        sk = detSecretKey (encodeUtf8 seed)+        addr = detGenKeyAddress (encodeUtf8 seed)+       in saveAlias aliasHint addr $ Just sk++    resolveSpecificOrDefaultAliasHint (SpecificAliasHint aliasHint) =+      return aliasHint+    resolveSpecificOrDefaultAliasHint (DefaultAliasHint) = do+      DefaultAliasCounter counter <- use psDefaultAliasesCounter+      psDefaultAliasesCounter %= \(DefaultAliasCounter i) -> DefaultAliasCounter $ i + 1+      return $ mkDefaultAlias counter++isAddressRefillable :: Address -> PureM Bool+isAddressRefillable addr = Set.member addr <$> use psRefillableAddresses++getBalance :: Address -> PureM Mutez+getBalance addr = do+  GState{..} <- use psGState+  return $ maybe zeroMutez asBalance $ Map.lookup addr gsAddresses++saveAlias :: AliasHint -> Address -> Maybe SecretKey -> PureM Address+saveAlias name addr mbSk = do+  psAliases %= Map.insert (hintToAlias name) (AliasData addr mbSk)+  pure addr++exceptionHandler :: PureM a -> PureM a+exceptionHandler action = try action >>= \case+  Left err -> exceptionToTransferFailure err >>= throwM+  Right res -> return res+  where+    exceptionToTransferFailure :: ExecutorError' AddressName -> PureM TransferFailure+    exceptionToTransferFailure err = case err of+      EEZeroTransaction addr -> return $ TransferFailure (addrNameToAddr addr) EmptyTransaction+      EEIllTypedParameter addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter+      EEUnexpectedParameterType addr _ _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter+      EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) ->+        case mfwsFailed of+          MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsInstrCallStack)+          MichelsonArithError (T.ShiftArithError{}) -> return $ TransferFailure (addrNameToAddr addr) ShiftOverflow+          MichelsonArithError (T.MutezArithError errType _ _) -> return $ TransferFailure (addrNameToAddr addr) $ MutezArithError errType+          MichelsonGasExhaustion -> return $ TransferFailure (addrNameToAddr addr) GasExhaustion+          _ -> throwM err+      _ -> throwM err+++getMorleyLogsImpl :: PureM a -> PureM (LogsInfo, a)+getMorleyLogsImpl action = swap <$> listen action++getStorageImpl+  :: forall st addr. (ToStorageType st addr)+  => addr -> PureM st+getStorageImpl addr = do+  withDict (pickNiceStorage @st addr) $ do+    ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toAddress addr)+    val <- castM @actualT @(ToT st) storage (throwM ... UnexpectedStorageType)+    pure $ T.fromVal val++-- Attempt to retrieve a ContractState given for the given address. Fails if the+-- address is unknown or the address is a simple address (contract without+-- code and storage).+contractStorage :: Address -> PureM ContractState+contractStorage addr = do+  GState{..} <- use psGState+  case Map.lookup addr gsAddresses of+    Just (ASContract contractState) -> pure contractState+    Just (ASSimple {}) -> throwM . CustomTestError $+      "Expected address to be contract with storage, but it's a simple address: " <> show addr+    Nothing -> unknownAddress addr++resolve :: Alias -> PureM Address+resolve name = do+  aliases <- use psAliases+  let maybeAddress = Map.lookup name aliases+  maybe (unknownAlias name) (pure . adAddress) maybeAddress++unknownAddress :: Address -> PureM whatever+unknownAddress =+  throwM . CustomTestError .+  mappend "Unknown address provided: " . pretty++unknownAlias :: Alias -> PureM whatever+unknownAlias =+  throwM . CustomTestError .+  mappend "Unknown address alias: " . pretty++-- | Make branch names for a case when we are not within any branch.+emptyScenarioBranch :: ScenarioBranchName+emptyScenarioBranch = ScenarioBranchName []++-- | Add a new branch element to names provided by inner+-- 'Test.Cleveland.branchout' calls.+appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName+appendScenarioBranch brName (ScenarioBranchName branches) =+  ScenarioBranchName (brName : branches)++----------------------------------------------------------------------------+-- Support functions+----------------------------------------------------------------------------++initAliases :: Alias -> Aliases+initAliases alias = one ( alias+                        , AliasData genesisAddress $+                          Just $ genesisSecretKey+                        )++initEnv :: Alias -> PureState+initEnv alias = PureState+  { _psAliases = initAliases alias+  , _psDefaultAliasesCounter = DefaultAliasCounter 0+  , _psRefillableAddresses = Set.empty+  , _psNow = dummyNow+  , _psLevel = dummyLevel+  , _psGState = initGState+  , _psExecutorResult = Nothing+  , _psContractsNames = Map.empty+  }++failedInsideBranch :: Text -> SomeException -> FailedInBranch+failedInsideBranch name err = case fromException @FailedInBranch err of+  Just (FailedInBranch branch failure) ->+    FailedInBranch (appendScenarioBranch name branch) failure+  Nothing ->+    FailedInBranch (appendScenarioBranch name emptyScenarioBranch) err++----------------------------------------------------------------------------+-- Emulator internals+----------------------------------------------------------------------------++transfer+  :: forall cp vd epRef epArg addr.+     (HasEntrypointArg cp epRef epArg, T.IsoValue epArg, L.ToTAddress cp vd addr)+  => "from" :! Address+  -> "to" :! addr+  -> Mutez+  -> epRef+  -> epArg+  -> PureM ()+transfer (N from) (N toAddr) money epRef param =+  let L.TAddress to' = L.toTAddress @cp @vd toAddr in+  case useHasEntrypointArg @cp @epRef @epArg epRef of+    (Dict, epName) -> registerInterpretation . one . Runtime.TransferOp $ TransferOperation+        { toDestination = to'+        , toCounter = 0+        , toTxData = TxData+          { tdSenderAddress = from+          , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $+              TxTypedParam (T.toVal param)+          , tdEntrypoint = epName+          , tdAmount = money+          }+        }++-- | Originate a contract with given initial storage and balance. Its+-- address is returned.+originate :: U.Contract -> Text -> U.Value -> Mutez -> PureM Address+originate uContract contractName uStorage balance =+  case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of+    Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr+    Right (T.SomeContractAndStorage contract storage) -> do+      counter <- gsCounter <$> use psGState+      result <- interpret . executeGlobalOrigination $+        (dummyOrigination storage contract counter) { ooBalance = balance }+      putResult $ fmap fst result+      address <- either throwEE (pure . snd) $ result++      psContractsNames %= Map.insert address contractName+      return address++throwEE :: ExecutorError -> PureM a+throwEE err = do+  st <- get+  throwM $ flip addrToAddrName st <$> err++-- | Put an interpreted result to InternalState.+putResult :: Either ExecutorError ExecutorRes -> PureM ()+putResult resOrErr = do+  let+    logs = case resOrErr of+      Left (EEInterpreterFailed addr (InterpretError e)) -> [ScenarioLogs addr $ snd e]+      Right res -> res ^. erInterpretResults <&> \(addr, InterpretResult{..}) ->+        ScenarioLogs addr iurMorleyLogs+      _ -> []+  tell logs+  case resOrErr of+    Right res -> psExecutorResult .= Just res+    Left err -> throwEE err++-- | Helper function which provides the results of the given operations.+interpret :: ExecutorM a -> PureM (Either ExecutorError (ExecutorRes, a))+interpret action = do+  now <- use psNow+  level <- use psLevel+  gState <- use psGState+  let interpretedResult = runExecutorM now level dummyMaxSteps gState action+  whenRight interpretedResult $ \(result, _) -> psGState .= _erGState result+  return interpretedResult++-- | Interprets provided list of operations.+registerInterpretation :: [Runtime.ExecutorOp] -> PureM ()+registerInterpretation ops =+  interpret (executeGlobalOperations def ops) <&> fmap fst >>= putResult++addrToAddrName :: Address -> PureState -> AddressName+addrToAddrName addr iState =+  AddressName (Map.lookup addr (iState ^. psContractsNames)) addr++addrNameToAddr :: AddressName -> Address+addrNameToAddr (AddressName _ addr) = addr
+ src/Test/Cleveland/Internal/Scenario.hs view
@@ -0,0 +1,56 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Cleveland.Internal.Scenario+  ( Scenario(..)+  , scenario+  , scenarioEmulated+  , withInitialNow+  , withInitialLevel+  ) where++import qualified Morley.Tezos.Core as TC+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Pure++-- | A type representing a finalized scenario+data Scenario m where+  ScenarioCleveland :: ClevelandT m () -> Scenario m+  ScenarioEmulated :: EmulatedT PureM () -> Scenario PureM++-- | Finalize a generic cleveland scenario.+scenario :: ClevelandT m () -> Scenario m+scenario = ScenarioCleveland++-- | Finalize a scenario that needs emulator-only features.+scenarioEmulated :: EmulatedT PureM () -> Scenario PureM+scenarioEmulated = ScenarioEmulated++withModifiedState+  :: (PureState -> PureState)+  -> Scenario PureM+  -> Scenario PureM+withModifiedState modfn = \case+  ScenarioEmulated emulated ->+    ScenarioEmulated $ lift (modify modfn) >> emulated+  ScenarioCleveland cleveland ->+    ScenarioCleveland $ lift (modify modfn) >> cleveland++-- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests.+--+-- Example :+-- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ scenarioEmulated $ tests+-- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ scenario $ tests+withInitialNow+  :: TC.Timestamp+  -> Scenario PureM+  -> Scenario PureM+withInitialNow = withModifiedState . set psNow++-- | Similar to 'withInitialNow' but for the initial level+withInitialLevel+  :: Natural+  -> Scenario PureM+  -> Scenario PureM+withInitialLevel = withModifiedState . set psLevel
+ src/Test/Cleveland/Lorentz.hs view
@@ -0,0 +1,76 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-deprecations #-}++module Test.Cleveland.Lorentz+  ( -- * Importing a contract+    specWithContract+  , specWithTypedContract+  , specWithUntypedContract+  , importContract+  , embedContract+  , embedContractM++  -- * Importing a value+  , importValue+  , embedValue+  , embedValueM++  -- * Unit testing+  , Michelson.ContractReturn+  , Michelson.ContractPropValidator+  , Michelson.contractProp+  , Michelson.contractPropVal+  , testContractCoversEntrypointsT+  , testContractMatchesEntrypointsT+  , testContractCoversEntrypoints+  , testContractMatchesEntrypoints++  -- * Basic types+  , ContractHandle (..)+  , chNiceParameterEvi+  , chNiceStorageEvi++  , ToStorageType (..)++  -- * Conversions+  , toAddress++  -- * Autodoc testing+  , runDocTests+  , testLorentzDoc+  , excludeDocTests++  -- * General utilities+  , failedTest+  , succeededTest+  , eitherIsLeft+  , eitherIsRight+  , meanTimeUpperBoundProp+  , meanTimeUpperBoundPropNF++  -- * Re-exports+  --+  -- | These functions from @Time@ are re-exported here to make it convenient to call+  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.+  , mcs, ms, sec, minute++  -- * Dummy values+  , dummyContractEnv++  -- * Special contracts for testing+  , contractConsumer+  ) where++import Test.Cleveland.Doc.Lorentz+import Test.Cleveland.Lorentz.Consumer+import Test.Cleveland.Lorentz.Entrypoints+import Test.Cleveland.Lorentz.Import+import Test.Cleveland.Lorentz.Types+import Test.Cleveland.Michelson.Dummy+import Test.Cleveland.Michelson.Import+  (specWithContract, specWithTypedContract, specWithUntypedContract)+import qualified Test.Cleveland.Michelson.Unit as Michelson+import Test.Cleveland.Util
+ src/Test/Cleveland/Lorentz/Consumer.hs view
@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Contract which remembers all parameters it has been called with.+--+-- Useful to save return values of @View_@ entry points.+module Test.Cleveland.Lorentz.Consumer+  ( contractConsumer+  ) where++import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Instr+import Lorentz.Run++-- | Remembers parameters it was called with, last goes first.+contractConsumer :: (NiceParameterFull cp, NiceStorage cp) => Contract cp [cp] ()+contractConsumer = defaultContract $+  unpair # cons # nil # pair
+ src/Test/Cleveland/Lorentz/Entrypoints.hs view
@@ -0,0 +1,36 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utility functions for checking predicates on contract's entrypoints for+-- Lorentz+module Test.Cleveland.Lorentz.Entrypoints+  ( -- * Entrypoint spec passed on the type level+    testContractCoversEntrypointsT+  , testContractMatchesEntrypointsT++    -- * Entrypoint spec passed as a value+  , testContractCoversEntrypoints+  , testContractMatchesEntrypoints+  ) where++import Test.Tasty (TestName)++import Test.Cleveland.Lorentz.Internal.Entrypoints+import Test.Cleveland.Michelson.Internal.Entrypoints (ignoreExtraEntrypoints)++-- | Expect the contract to cover or exactly match with the entrypoints given in spec passed as the+-- first type argument. Checks both the contract type and the contract itself (when represented as+-- an untyped Michelson contract).+testContractCoversEntrypointsT,+  testContractMatchesEntrypointsT :: forall exp. TestName -> ContractEPTypeTest exp+testContractCoversEntrypointsT = testCompareContractEntrypointsT @exp ignoreExtraEntrypoints+testContractMatchesEntrypointsT = testCompareContractEntrypointsT @exp id++-- | Expect the contract to cover or exactly match with the entrypoints given in spec passed as a+-- 'Map' of names to types. Checks both the contract type and the contract itself (when represented as+-- an untyped Michelson contract).+testContractCoversEntrypoints,+  testContractMatchesEntrypoints :: TestName -> ContractEPTest contractEps st vd+testContractCoversEntrypoints = testCompareContractEntrypoints ignoreExtraEntrypoints+testContractMatchesEntrypoints = testCompareContractEntrypoints id
+ src/Test/Cleveland/Lorentz/Import.hs view
@@ -0,0 +1,161 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Functions to import contracts to be used in tests.+module Test.Cleveland.Lorentz.Import+  ( -- * Read, parse, typecheck contracts+    importContract+  , embedContract+  , embedContractM+  , M.ContractReadError (..)++    -- * Read, parse, typecheck values+  , importValue+  , embedValue+  , embedValueM+  , M.ValueReadError (..)++    -- * Notes+    -- $embedDepends+  ) where++import Fmt (build, pretty)+import qualified Language.Haskell.TH as TH++import qualified Lorentz as L+import Lorentz.Base+import Lorentz.Constraints+import Lorentz.ViewBase+import Morley.Michelson.Parser.Types (MichelsonSource(..))+import qualified Morley.Michelson.Typed as T+import Morley.Util.Markdown+import qualified Test.Cleveland.Michelson.Import as M++mkImportedContract+  :: forall cp st vd.+     (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)+  => FilePath+  -> T.Contract (T.ToT cp) (T.ToT st)+  -> Either L.ViewInterfaceMatchError (Contract cp st vd)+mkImportedContract path cMichelsonContract = verifyingViews Contract+  { cDocumentedCode =+      L.fakeCoercing $+        L.docGroup "Imported contract" $+          L.doc $ L.DDescription $ "Read from " <> mdTicked (build path)+  , ..+  }+  where+    verifyingViews r =+      L.checkViewsCoverInterface (L.demoteViewsDescriptor @vd) (T.cViews cMichelsonContract)+      $> r++-- | Import contract from a given 'FilePath'.+--+-- In this and similar functions, parameter and storage types must exactly match+-- the ones in the contract, while for views this is not necessary. Only+-- make sure that all views beyond @vd@ type are present in the contract; @()@+-- always works as views descriptor of the contract.+importContract+  :: forall cp st vd.+     (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)+  => FilePath -> IO (Contract cp st vd)+importContract file =+  either throwM pure . mkImportedContract file =<< M.importContract file++{- | Import a contract at compile time assuming its expected type is known.++Use it like:++> myContract :: Contract Parameter Storage+> myContract = $$(embedContract "my_contract.tz")++or++> let myContract = $$(embedContract @Parameter @Storage "my_contract.tz")++See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"+-}+embedContract+  :: forall cp st vd.+    (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)+  => FilePath -> TH.TExpQ (Contract cp st vd)+embedContract path = embedContractM (pure path)++-- | Version of 'embedContract' that accepts a filepath constructor in IO.+--+-- Useful when the path should depend on environmental variables or other+-- user input.+--+-- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"+embedContractM+  :: forall cp st vd.+    (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)+  => IO FilePath -> TH.TExpQ (Contract cp st vd)+embedContractM pathM = do+  path <- TH.runIO pathM+  contract <- M.embedTextFile path+  case M.readContract @(T.ToT cp) @(T.ToT st) (MSFile path) contract of+    Left e ->+      -- Emit a compiler error if the contract cannot be read.+      fail (pretty e)+    Right tContract -> case mkImportedContract @cp @st @vd path tContract of+      Left e ->+        -- Emit a compiler error if there are issues with constructing contract+        fail (pretty e)+      -- Emit a haskell expression that reads the contract.+      Right _ -> [||+          -- Note: it's ok to use `error` here, because we just proved that the contract+          -- can be parsed+typechecked.+          contract+            & M.readContract (MSFile path)+            & either (error . pretty) id+            & mkImportedContract path+            & either (error . pretty) id+        ||]++-- | Import a value from a given 'FilePath'+importValue :: forall a . T.IsoValue a => FilePath -> IO a+importValue = fmap T.fromVal . M.importValue++{- | Import a value from a given 'FilePath' at compile time+and embed it as a value using Template Haskell, f. ex.++> let someAddress = $$(embedValue @Address "/path/to/addressFile.tz")++See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"+-}+embedValue :: forall a . T.IsoValue a => FilePath -> TH.TExpQ a+embedValue = embedValueM . pure++-- | A variant of 'embedValue' that accepts 'FilePath' in 'IO'.+--+-- Can be useful when 'FilePath' depends on the environment.+--+-- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"+embedValueM :: forall a . T.IsoValue a => IO FilePath -> TH.TExpQ a+embedValueM pathM = do+  path <- TH.runIO pathM+  rawValue <- M.embedTextFile path+  case M.readValue @(T.ToT a) (MSFile path) rawValue of+    Left e -> fail (pretty e)+    Right _ ->+          [||+            -- Note: it's ok to use `error` here, because we just proved that the value+            -- can be parsed+typechecked.+            either (error . pretty) T.fromVal $+              M.readValue (MSFile path) rawValue+          ||]++{- $embedDepends++= On 'FilePath' argument with 'embedContract', 'embedValue' and variants #embedDepends#++The 'FilePath' argument is specified relative to the project root (if+using cabal-install or stack, the directory containing the Cabal file and/or @package.yaml@).++As an additional caveat, any files embedded this way are essentially compile-time dependencies. However,+build systems can't track these automatically. In general, it's advisable to add the files used+with 'embedContract', 'embedValue' and variants to the @extra-source-files@ section of the Cabal+file or @package.yaml@, if possible.+-}
+ src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs view
@@ -0,0 +1,74 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Internal utilities for unit testing.++module Test.Cleveland.Lorentz.Internal.Entrypoints+  ( -- * Entrypoint spec passed on the type level+    testCompareContractEntrypointsT++    -- * Entrypoint spec passed as a value+  , testCompareContractEntrypoints++    -- * Utility types+  , ContractEPTypeTest+  , ContractEPTest+  ) where++import Lorentz hiding (contract)++import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Morley.Michelson.Typed (convertContract, flattenEntrypoints)+import qualified Morley.Michelson.Untyped as U++import qualified Test.Cleveland.Michelson.Internal.Entrypoints as M++-- | Utility type synonym+type ContractEPTypeTest expectedEps+  =  forall contractEps st vd. NiceParameterFull expectedEps+  => Contract contractEps st vd -> TestTree++-- | Utility type synonym+type ContractEPTest contractEps st vd+  =  Contract contractEps st vd+  -> Map EpName U.Ty+  -> TestTree++-- | Expect the contract to match with the entrypoints given in spec passed as the first type+-- argument. Checks both the contract type and the contract itself (when represented as an untyped+-- Michelson contract).+-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,+-- @id@ for match test.+testCompareContractEntrypointsT+  :: forall expectedEps.+     (M.EPMismatch -> M.EPMismatch)+  -> TestName -> ContractEPTypeTest expectedEps+testCompareContractEntrypointsT compareMode name contract =+  withDict (niceParameterEvi @expectedEps) $+    let entrypoints = flattenEntrypoints $ parameterEntrypointsToNotes @expectedEps+    in testCompareContractEntrypoints compareMode name contract entrypoints++-- | Expect the contract to match with the entrypoints given in spec (with matching types).+-- Checks both the contract type and the contract itself (when represented as an untyped Michelson+-- contract).+-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,+-- @id@ for match test.+testCompareContractEntrypoints+  :: forall contractEps st vd.+     (M.EPMismatch -> M.EPMismatch)+  -> TestName -> ContractEPTest contractEps st vd+testCompareContractEntrypoints compareMode name contract@Contract{} spec =+  withDict (niceParameterEvi @contractEps) $+  withDict (niceStorageEvi @st) $+    let entrypointsInType = flattenEntrypoints $ parameterEntrypointsToNotes @contractEps+        contract' = convertContract . toMichelsonContract $ contract+    in testGroup name+        [ testCase "Contract type matches entrypoint spec" $+            M.assertEPComparisonSuccessful . Right . compareMode $+              M.compareEntrypoints (M.EPExpected spec) (M.EPActual entrypointsInType)+        , M.testContractEntrypoints compareMode+            "Untyped contract matches entrypoint spec" contract' spec+        ]
+ src/Test/Cleveland/Lorentz/Requester.hs view
@@ -0,0 +1,39 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Contract that call on-chain views and keep the result in storage.+--+-- This is like 'Test.Clevelad.Lorentz.Consumer.contractConsumer', but it is+-- _active_ - you call it, not the contract containing the view, in order to+-- access the view.+--+-- TODO [#708]: mention that calling views directly should be preferred.+module Test.Cleveland.Lorentz.Requester+  ( contractRequester+  ) where++import Lorentz+import Prelude hiding (swap, view)++import Morley.Util.TypeLits+import Test.Cleveland.Lorentz.Types++-- | Allows calling a view multiple times, remembering results in+-- last-goes-first order.+--+-- > contractRequester @"viewName" contractWithView+contractRequester+  :: forall name arg ret vd cp st.+     ( NiceParameterFull cp, NiceStorage cp+     , NiceParameterFull arg, NiceStorage [ret]+     , NiceViewable arg, NiceViewable ret, HasView vd name arg ret+     , Typeable vd, KnownSymbol name+     )+  => ContractHandle cp st vd -> Contract arg [ret] ()+contractRequester target = defaultContract $+  unpair #+  push (toTAddress target) # swap # view @name # cons #+  nil # pair
+ src/Test/Cleveland/Lorentz/Ticketer.hs view
@@ -0,0 +1,70 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Contract that facilitates tickets emission.+module Test.Cleveland.Lorentz.Ticketer+  ( ticketerContract'+  , ticketerContract+  , callViaTicketer+  ) where++import Lorentz+import Prelude (HasCallStack)++import Test.Cleveland++-- | A contract that emits the desired tickets.+--+-- It has one entrypoint - a 'View_' where you supply ticket+-- data and tokens amount, and a callback contract that+-- should receive an argument with the ticket.+--+-- You also have to supply a lambda that attaches a payload+-- to the ticket, since tickets are usually attached to some+-- other data.+ticketerContract'+  :: ( NiceComparable td+     , NiceParameterFull (View_ (payload, (Natural, td)) callbackArg)+     , NiceParameter callbackArg+     )+  => [payload, Ticket td] :-> '[callbackArg]+  -> Contract (View_ (payload, (Natural, td)) callbackArg) () ()+ticketerContract' mkCallbackArg = defaultContract $+  unpair # view_+    ( dip (drop @()) # unpair # dip (unpair # swap # ticket) # framed mkCallbackArg+    )++-- | A simpler version of 'ticketerContract\'' where the target+-- contract will always receive a pair of payload and ticket.+ticketerContract+  :: ( NiceComparable td+     , callbackArg ~ (payload, Ticket td)+     , NiceParameterFull (View_ (payload, (Natural, td)) callbackArg)+     , NiceParameter callbackArg+     )+  => Contract (View_ (payload, (Natural, td)) callbackArg) () ()+ticketerContract = ticketerContract' pair++-- | Run a contract indirectly via calling the given ticketer contract.+--+-- The target contract will recieve a ticket and some payload. The exact+-- structure of the passed argument is determined by the ticketer contract.+callViaTicketer+  :: forall targetArg payload td targetAddr ticketerParam ticketerAddr m.+     ( HasCallStack+     , MonadOps m+     , ticketerParam ~ View_ (payload, (Natural, td)) targetArg+     , ToTAddress ticketerParam () ticketerAddr+     , ToContractRef targetArg targetAddr+     , NiceParameterFull ticketerParam+     )+  => ticketerAddr  -- ^ Address of ticketer contract+  -> Natural       -- ^ Desired ticket amount+  -> td            -- ^ Desired ticket data+  -> targetAddr    -- ^ Contract to call indirectly+  -> payload       -- ^ Main argument passed to the ticketer+  -> m ()+callViaTicketer ticketer ticketAmount ticketData target payload =+  call @ticketerParam @() ticketer CallDefault+    (mkView_ (payload, (ticketAmount, ticketData)) target)
+ src/Test/Cleveland/Lorentz/Types.hs view
@@ -0,0 +1,100 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Basic types for the test framework.+module Test.Cleveland.Lorentz.Types+  ( ContractHandle (..)+  , chNiceParameterEvi+  , chNiceStorageEvi++  , ToStorageType (..)++  , NiceParameter+  , NiceParameterFull+  , NiceStorage+  , NicePackedValue+  , NiceUnpackedValue++  , ToAddress+  , toAddress++  -- * Notes+  -- $noteTAddress+  ) where++import Data.Constraint (Dict(..), mapDict)+import Fmt (Buildable(..), (+|), (|+))++import Lorentz.Address+import Lorentz.Constraints+import qualified Morley.Michelson.Typed as T++-- | Handle to a contract.+--+-- This is what you get when originating a contract and that allows further+-- operations with the contract within the test framework.+--+-- Note that this is part of the testing framework and exists solely in Haskell+-- world, so it has no 'T.IsoValue' and related instances and cannot be used in+-- Lorentz code.+data ContractHandle (cp :: Type) (st :: Type) (vd :: Type) =+  (NiceParameterFull cp, NiceStorage st, NiceViewsDescriptor vd) =>+  ContractHandle+  { chContractName :: Text+  , chAddress :: Address+  }++deriving stock instance Show (ContractHandle cp st vd)++instance Buildable (ContractHandle cp st vd) where+  build (ContractHandle name addr) =+    "<handler to '" +| name |+ "' / " +| addr |+ ">"++instance ToAddress (ContractHandle cp st vd) where+  toAddress = chAddress++-- TODO [#577]: simplify this instance once fundep in ToTAddress is added+instance (cp' ~ cp, vd ~ vd') => ToTAddress cp' vd' (ContractHandle cp st vd) where+  toTAddress = toTAddress . toAddress++instance ToContractRef arg (TAddress cp vd) => ToContractRef arg (ContractHandle cp st vd) where+  toContractRef = toContractRef . toTAddress @cp++-- | Extract the evidence in typed Michelson that the parameter type is valid+-- for such scope.+chNiceParameterEvi :: forall param st vd. ContractHandle param st vd -> Dict (T.ParameterScope $ T.ToT st)+chNiceParameterEvi ContractHandle{} = mapDict (niceParameterEvi @st) Dict++-- | Extract the evidence in typed Michelson that the storage type is valid+-- for such scope.+chNiceStorageEvi :: forall param st vd. ContractHandle param st vd -> Dict (T.StorageScope $ T.ToT st)+chNiceStorageEvi ContractHandle{} = mapDict (niceStorageEvi @st) Dict++-- | Declares that @addr@ points to an entity with a storage.+--+-- @addr@ may fix storage type or may not - in the latter case the caller+-- has to specify the storage type explicitly via type annotation.+class ToAddress addr => ToStorageType st addr where+  -- | Pick proof of that storage type is valid.+  pickNiceStorage :: addr -> Dict (NiceStorage st)++instance NiceStorage st => ToStorageType st Address where+  pickNiceStorage _ = Dict++instance (st ~ st') => ToStorageType st' (ContractHandle cp st vd) where+  pickNiceStorage ContractHandle{} = Dict++{- $noteTAddress++  == A note on 'TAddress' instance for 'ToStorageType'++  'TAddress' isn't intended to be a part of the Cleveland API.+  In the absolute majority of cases, if one is interested in both parameter+  and storage, then they should use 'ContractHandle', as the storage type+  needs to be known either way. If one isn't interested in storage, they+  presumably wouldn't call functions to get storage. Hence, this instance+  wouldn't be particularly useful. Legacy code using 'TAddress' instead of+  'ContractHandle' should be preferably updated, if possible. If nothing+  else, 'toAddress' can be used as a stopgap measure.+-}
+ src/Test/Cleveland/Michelson.hs view
@@ -0,0 +1,67 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Module containing some utilities for testing Michelson contracts using+-- Haskell testing frameworks.+-- It's Morley testing EDSL.+-- We focus on @tasty@ and @hedgehog@ because that's what we mostly use in+-- our tests, but we also provide helpers for @hspec@, and defining helpers+-- for other libraries (e. g. @QuickCheck@) shouldn't be hard.+-- We don't provide helpers for other libraries to have less dependencies.++module Test.Cleveland.Michelson+  ( -- * Importing a contract+    specWithContract+  , specWithTypedContract+  , specWithUntypedContract+  , testTreesWithContract+  , testTreesWithUntypedContract+  , testTreesWithTypedContract+  , concatTestTrees+  , importContract+  , importSomeContract+  , importUntypedContract++  -- * Unit testing+  , ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  , validateSuccess+  , validateStorageIs+  , validateMichelsonFailsWith+  , testContractCoversEntrypoints+  , testContractMatchesEntrypoints++  -- * General utilities+  , failedTest+  , succeededTest+  , eitherIsLeft+  , eitherIsRight+  , meanTimeUpperBoundProp+  , meanTimeUpperBoundPropNF++  -- * Re-exports+  --+  -- | These functions from @Time@ are re-exported here to make it convenient to call+  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.+  , mcs, ms, sec, minute++  -- * Autodoc testing+  , runDocTests+  , testDocBasic+  , excludeDocTests++  -- * Dummy values+  , dummyContractEnv+  ) where++import Test.Cleveland.Doc.Michelson+import Test.Cleveland.Michelson.Dummy+import Test.Cleveland.Michelson.Entrypoints+import Test.Cleveland.Michelson.Import+import Test.Cleveland.Michelson.Unit+import Test.Cleveland.Util
+ src/Test/Cleveland/Michelson/Dummy.hs view
@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Dummy data to be used in tests where it's not essential.++module Test.Cleveland.Michelson.Dummy+  {-# DEPRECATED "Use Morley.Michelson.Runtime.Dummy or Morley.Tezos.Core directly instead" #-}+  ( dummyNow+  , dummyLevel+  , dummyMaxSteps+  , dummyBigMapCounter+  , dummyContractEnv+  , dummyGlobalCounter+  , dummyOrigination+  , dummyChainId+  ) where++import Morley.Michelson.Runtime.Dummy+import Morley.Tezos.Core
+ src/Test/Cleveland/Michelson/Entrypoints.hs view
@@ -0,0 +1,50 @@+-- SPDX-FileCopyrightText: 2022 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Utility functions for checking predicates on contract's entrypoints.++module Test.Cleveland.Michelson.Entrypoints+  ( contractHasEntrypoints+  , testContractCoversEntrypoints+  , testContractMatchesEntrypoints+  , mkEntrypointsMap+  , hasEp+  ) where++import Test.Tasty (TestName, TestTree)++import Morley.Michelson.Untyped hiding (Contract)+import qualified Morley.Michelson.Untyped as U++import Test.Cleveland.Michelson.Internal.Entrypoints++-- | Check if entrypoint is present in `T`.+hasEp :: T -> (EpName, U.Ty) -> Bool+hasEp (TOr lFieldAnn rFieldAnn lType@(Ty lT _) rType@(Ty rT _))+      ep@(epNameToParamAnn -> epAnn, epType) = or+  [ (epAnn == lFieldAnn && epType == lType)+  , (epAnn == rFieldAnn && epType == rType)+  , hasEp lT ep+  , hasEp rT ep ]+hasEp _ _ = False++-- | Check whether the given set of entrypoints is present in contract.+contractHasEntrypoints :: U.Contract -> Map EpName U.Ty -> Bool+contractHasEntrypoints contract eps = case contractCoversEntrypoints contract eps of+  Right EPComparisonResultOK -> True+  _ -> False++-- | Assert the contract contains the entrypoints given in spec (with matching types).+-- Ignores any additional entrypoints present in the contract.+--+-- Also tests if the same holds after Michelson and Micheline roundtrips of the contract.+testContractCoversEntrypoints :: TestName -> U.Contract -> Map EpName U.Ty -> TestTree+testContractCoversEntrypoints = testContractEntrypoints ignoreExtraEntrypoints++-- | Assert the contract exactly matches the given entrypoints. Will report both+-- missing and extraneous entrypoint names, and type mismatches.+--+-- Also tests if the same holds after Michelson and Micheline roundtrips of the contract.+testContractMatchesEntrypoints :: TestName -> U.Contract -> Map EpName U.Ty -> TestTree+testContractMatchesEntrypoints = testContractEntrypoints id
+ src/Test/Cleveland/Michelson/Import.hs view
@@ -0,0 +1,208 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Functions to import contracts to be used in tests.++module Test.Cleveland.Michelson.Import+  (+    -- * Read, parse, typecheck+    readContract+  , readUntypedContract+  , readSomeContract+  , importContract+  , importUntypedContract+  , importSomeContract+  , embedContract+  , embedContractM+  , ContractReadError (..)++  -- * Read, parse, typecheck value+  , readValue+  , importValue+  , importSomeValue+  , importUntypedValue+  , ValueReadError (..)++    -- * Tasty helpers+  , testTreesWithContract+  , testTreesWithTypedContract+  , testTreesWithUntypedContract+  , concatTestTrees++    -- * HSpec helpers+  , specWithContract+  , specWithTypedContract+  , specWithUntypedContract++    -- * Helpers+  , embedTextFile+  ) where++import Control.Exception (IOException)+import Data.FileEmbed (makeRelativeToProject)+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Fmt (pretty)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (qAddDependentFile)+import Test.HUnit (assertFailure)+import Test.Hspec (Spec, describe, expectationFailure, it, runIO)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Morley.Michelson.Runtime.Import+import Morley.Michelson.Typed (Contract, SingI)+import qualified Morley.Michelson.Untyped as U++{-# DEPRECATED+    specWithContract+  , specWithTypedContract+  , specWithUntypedContract++  "Use testTreesWithContract &c. instead"+  #-}++----------------------------------------------------------------------------+-- tasty helpers+----------------------------------------------------------------------------++-- | Import contract and use to create test trees. Both versions of contract are+-- passed to the callback function (untyped and typed).+--+-- If contract's import fails, a tree with single failing test will be generated+-- (so test tree will likely be generated unexceptionally, but a failing+-- result will notify about problem).+testTreesWithContract+  :: (Each '[SingI] [cp, st], HasCallStack)+  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]+testTreesWithContract = testTreesWithContractImpl importContract++-- | Like 'testTreesWithContract' but supplies only untyped contract.+testTreesWithUntypedContract+  :: HasCallStack+  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]+testTreesWithUntypedContract =+  testTreesWithContractImpl importUntypedContract++-- | Like 'testTreesWithContract' but supplies only typed contract.+testTreesWithTypedContract+  :: (Each '[SingI] [cp, st], HasCallStack)+  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]+testTreesWithTypedContract =+  testTreesWithContractImpl importContract++testTreesWithContractImpl+  :: HasCallStack+  => (FilePath -> IO contract)+  -> FilePath+  -> (contract -> IO [TestTree])+  -> IO [TestTree]+testTreesWithContractImpl doImport file testImpl =+  saferImport doImport file >>= \case+    Left err -> pure [testCase ("Import contract " <> file) $ assertFailure err]+    Right contract -> testImpl contract++-- A helper function which allows you to use multiple+-- 'testTreesWithTypedContract' in a single top-level test with type+-- 'IO [TestTree]'.+concatTestTrees :: [IO [TestTree]] -> IO [TestTree]+concatTestTrees = fmap concat . sequence++----------------------------------------------------------------------------+-- hspec helpers+----------------------------------------------------------------------------++-- | Import contract and use it in the spec. Both versions of contract are+-- passed to the callback function (untyped and typed).+--+-- If contract's import fails, a spec with single failing expectation+-- will be generated (so tests will likely run unexceptionally, but a failing+-- result will notify about problem).+specWithContract+  :: (Each '[SingI] [cp, st], HasCallStack)+  => FilePath -> (Contract cp st -> Spec) -> Spec+specWithContract = specWithContractImpl importContract++-- | A version of 'specWithContract' which passes only the typed+-- representation of the contract.+specWithTypedContract+  :: (Each '[SingI] [cp, st], HasCallStack)+  => FilePath -> (Contract cp st -> Spec) -> Spec+specWithTypedContract = specWithContractImpl importContract++specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec+specWithUntypedContract = specWithContractImpl importUntypedContract++specWithContractImpl+  :: HasCallStack+  => (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec+specWithContractImpl doImport file execSpec =+  either errorSpec (describe ("Test contract " <> file) . execSpec)+    =<< runIO (saferImport doImport file)+  where+    errorSpec = it ("Import contract " <> file) . expectationFailure++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- Catch some errors during contract import, we don't want the whole+-- test suite to crash if something like that happens.+saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)+saferImport doImport file =+  ((Right <$> doImport file)+  `catch` \(e :: ContractReadError) -> pure $ Left $ displayException e)+  `catch` \(e :: IOException) -> pure $ Left $ displayException e++----------------------------------------------------------------------------+-- Embedding contract+----------------------------------------------------------------------------++-- | Read a file with textual content at compile time.+--+-- Unlike @embedFile@ from the library, returns typed content.+embedTextFile :: FilePath -> TH.Q Text+embedTextFile rawPath = do+  path <- makeRelativeToProject rawPath+  qAddDependentFile rawPath+  Utf8.readFile path++{- | Import a contract at compile time assuming its expected type is known.++Use it like:++> myContract :: Contract (ToT Parameter) (ToT Storage)+> myContract = $$(embedContract "my_contract.tz")++or++> let myContract = $$(embedContract @(ToT Parameter) @(ToT Storage) "my_contract.tz")++-}+embedContract+  :: forall cp st. (SingI cp, SingI st)+  => FilePath -> TH.TExpQ (Contract cp st)+embedContract path = embedContractM (pure path)++-- | Version of 'embedContract' that accepts a filepath constructor in IO.+--+-- Useful when the path should depend on environmental variables or other+-- user input.+embedContractM+  :: forall cp st. (SingI cp, SingI st)+  => IO FilePath -> TH.TExpQ (Contract cp st)+embedContractM pathM = do+  path <- TH.runIO pathM+  contract <- embedTextFile path+  case readContract @cp @st (MSFile path) contract of+    Left e ->+      -- Emit a compiler error if the contract cannot be read.+      fail (pretty e)+    Right _ ->+      -- Emit a haskell expression that reads the contract.+      [||+        -- Note: it's ok to use `error` here, because we just proved that the contract+        -- can be parsed+typechecked.+        either (error . pretty) id $+          readContract (MSFile path) contract+      ||]
+ src/Test/Cleveland/Michelson/Internal/Entrypoints.hs view
@@ -0,0 +1,158 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Internal utilities for unit testing.++module Test.Cleveland.Michelson.Internal.Entrypoints+  ( EPList+  , EPExpected(..)+  , EPActual(..)+  , EPMismatch(.., EPComparisonResultOK)+  , ignoreExtraEntrypoints+  , compareEntrypoints+  , contractMatchesEntrypoints+  , contractCoversEntrypoints+  , testContractEntrypoints+  , assertEPComparisonSuccessful+  , michelsonRoundtripContract+  , michelineRoundtripContract+  ) where++import Data.Aeson (eitherDecode, encode)+import qualified Data.Map as Map+import Fmt (Buildable(..), blockMapF, indentF, nameF, pretty, unlinesF, (+|), (|+))+import Test.HUnit (Assertion, assertFailure)+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Morley.Micheline (fromExpression, toExpression)+import Morley.Michelson.Parser (MichelsonSource(MSUnspecified))+import Morley.Michelson.Printer (printUntypedContract)+import Morley.Michelson.Runtime (parseExpandContract)+import Morley.Michelson.TypeCheck (TCError, mkSomeParamType)+import Morley.Michelson.Untyped hiding (Contract)+import qualified Morley.Michelson.Untyped as U++-- | Convenience type synonym for a list of pairs of entrypoint names and types+type EPList = [(EpName, U.Ty)]++-- | Newtype wrapper for the expected value in entrypoint comparison+newtype EPExpected a = EPExpected a+  deriving stock (Eq, Show)++-- | Newtype wrapper for the actual value in entrypoint comparison+newtype EPActual a = EPActual a+  deriving stock (Eq, Show)++-- | A pattern syononym for no mismatches+pattern EPComparisonResultOK :: EPMismatch+pattern EPComparisonResultOK <- EPMismatch [] [] []++-- | Entrypoint comparison mismatch report+data EPMismatch = EPMismatch+  { epmmExtra :: EPList+    -- ^ Extraneous entrypoints, i.e. those that exist in the actual contract, but not+    -- in the specification+  , epmmMissing :: EPList+    -- ^ Missing entrypoints, i.e. those that exist in the specification, but not the+    -- actual contract+  , epmmTypeMismatch :: [(EpName, (EPExpected U.Ty, EPActual U.Ty))]+    -- ^ Entrypoints that exist in both the contract and the specification, but types do not+    -- match.+  } deriving stock (Eq, Show)++instance Buildable EPMismatch where+  build EPComparisonResultOK = "Entrypoints match specificaton"+  build EPMismatch{..} = nameF "Entrypoints do not match specification" $ indentF 2 $+    unlinesF $ filter (/=mempty) [extra, missing, typemm]+    where+    extra | null epmmExtra = mempty+          | otherwise = nameF "Extraneous entrypoints in the contract" $ blockMapF epmmExtra+    missing | null epmmMissing = mempty+            | otherwise = nameF "Missing entrypoints in the contract" $ blockMapF epmmMissing+    typemm | null epmmTypeMismatch = mempty+           | otherwise = nameF "Type mismatch in entrypoints" $ blockMapF epmmTypeMismatch++instance Buildable (EPExpected Ty, EPActual Ty) where+  build (expected, actual) = "" +| expected |+ ", " +| actual |+ ""++instance Buildable a => Buildable (EPExpected a) where+  build (EPExpected x) = nameF "Expected" $ build x++instance Buildable a => Buildable (EPActual a) where+  build (EPActual x) = nameF "Actual" $ build x++-- | Ignore extraneous entrypoint names in 'EPMismatch'. Essentially sets+-- 'epmmExtra' to @[]@.+ignoreExtraEntrypoints :: EPMismatch -> EPMismatch+ignoreExtraEntrypoints mm = mm{ epmmExtra = [] }++-- | Compare two sets of entrypoints. Accepts ordered 'Map's to enforce sorting order.+compareEntrypoints :: EPExpected (Map EpName U.Ty) -> EPActual (Map EpName U.Ty) -> EPMismatch+compareEntrypoints (EPExpected expected) (EPActual actual) = EPMismatch{..}+  where+    epmmExtra = Map.toList $ Map.difference actual expected+    epmmMissing = Map.toList $ Map.difference expected actual+    inBoth = Map.intersectionWith (,) expected actual+    epmmTypeMismatch = Map.toList $ Map.map (bimap EPExpected EPActual) $ Map.filter (uncurry (/=)) inBoth++-- | Check if the contract exactly matches the given entrypoints. Will report both+-- missing and extraneous entrypoint names, and type mismatches.+contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TCError EPMismatch+contractMatchesEntrypoints (contractParameter -> pt) expected = case mkSomeParamType pt of+  Right{} -> Right $ compareEntrypoints (EPExpected expected) (EPActual $ mkEntrypointsMap pt)+  Left err -> Left err++-- | Check if the contract contains the entrypoints given in spec (with matching types).+-- Ignores any additional entrypoints present in the contract.+contractCoversEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TCError EPMismatch+contractCoversEntrypoints = second ignoreExtraEntrypoints ... contractMatchesEntrypoints++-- | Turn 'Either' 'TCError' 'EPMismatch' into an 'Assertion'+assertEPComparisonSuccessful :: Either TCError EPMismatch -> Assertion+assertEPComparisonSuccessful = \case+  Right EPComparisonResultOK -> pass+  Left tcerr -> assertFailure $ pretty tcerr+  Right mismatch -> assertFailure $ pretty mismatch++-- | Expect the contract to match with the entrypoints given in spec (with matching types).+-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,+-- @id@ for match test.+--+-- Also tests if the same holds after Michelson and Micheline roundtrips of the contract.+testContractEntrypoints+  :: (EPMismatch -> EPMismatch)+  -> TestName+  -> U.Contract+  -> Map EpName U.Ty+  -> TestTree+testContractEntrypoints compMode name contract spec+  = testGroup name+      [ testCase "Contract itself" $ test id+      , testCase "After Michelson roundtrip" $ test michelsonRoundtripContract+      , testCase "After Micheline roundtrip" $ test michelineRoundtripContract+      ]+  where test modifier = assertEPComparisonSuccessful $ second compMode $ contractMatchesEntrypoints (modifier contract) spec++-- | Round-trip the contract through Michelson text representation.+--+-- This is useful if you're intending to use the contract with Michelson text output and want to+-- check if that output satisfies tests (which /should be/ the same for internal representation+-- and output, but bugs happen)+michelsonRoundtripContract :: HasCallStack => U.Contract -> U.Contract+michelsonRoundtripContract contract =+  either (error . pretty) id . parseExpandContract MSUnspecified . toText+    $ printUntypedContract True contract++-- | Round-trip the contract through Micheline JSON representation.+--+-- This is useful if you're intending to use the contract with Micheline JSON output and want to+-- check if that output satisfies tests (which /should be/ the same for internal representation+-- and output, but bugs happen)+michelineRoundtripContract :: HasCallStack => U.Contract -> U.Contract+michelineRoundtripContract contract =+  either (error . pretty) id . fromExpression+    . either (error . toText) id+    . eitherDecode . encode+    $ toExpression contract
+ src/Test/Cleveland/Michelson/Unit.hs view
@@ -0,0 +1,109 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Utility functions for unit testing.++module Test.Cleveland.Michelson.Unit+  {-# DEPRECATED "Use the new Test.Cleveland interface instead. Entrypoint utilities\+  \ are moved to Test.Cleveland.Michelson.Entrypoints" #-}+  ( ContractReturn+  , ContractPropValidator+  , EPMismatch+  , contractProp+  , contractPropVal+  , validateSuccess+  , validateStorageIs+  , validateMichelsonFailsWith+  ) where++import Data.Constraint ((\\))+import Fmt ((+|), (|+))+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy)++import Lorentz.Constraints.Scopes (NiceConstant, niceConstantEvi)+import Morley.Michelson.Interpret+  (ContractEnv, ContractReturn, MichelsonFailed(..), MichelsonFailureWithStack(..), interpret)+import Morley.Michelson.Typed (Contract, IsoValue(..), ToT)+import qualified Morley.Michelson.Typed as T+import Test.Cleveland.Michelson.Dummy (dummyBigMapCounter, dummyGlobalCounter)+import Test.Cleveland.Michelson.Internal.Entrypoints++-- | Type for contract execution validation.+--+-- It's a function which is supplied with contract execution output+-- (failure or new storage with operation list).+--+-- Function returns a property which type is designated by type variable @prop@+-- and might be @Test.QuickCheck.Property@ or 'Expectation'+-- or anything else relevant.+type ContractPropValidator st prop = ContractReturn st -> prop++-- | ContractCode's property tester against given input.+-- Takes contract environment, initial storage and parameter,+-- interprets contract on this input and invokes validation function.+contractProp+  :: ( IsoValue param, IsoValue storage+     , ToT param ~ cp, ToT storage ~ st+     , T.ParameterScope cp+     )+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> param+  -> storage+  -> prop+contractProp instr check env param initSt =+  contractPropVal instr check env (toVal param) (toVal initSt)++-- | Version of 'contractProp' which takes 'T.Value' as arguments instead+-- of regular Haskell values.+--+-- This function assumes that contract has no explicit default entrypoints+-- and you always have to construct parameter manually; if you need to test+-- contract calling specific entrypoints, use integrational testing defined+-- by "Test.Cleveland.Michelson.Integrational" module.+contractPropVal+  :: (T.ParameterScope cp)+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> T.Value cp+  -> T.Value st+  -> prop+contractPropVal instr check env param initSt =+  check $ interpret instr T.unsafeEpcCallRoot param initSt dummyGlobalCounter dummyBigMapCounter env++----------------------------------------------------------------------------+-- Validators+----------------------------------------------------------------------------++-- | 'ContractPropValidator' that expects a successful termination.+validateSuccess :: HasCallStack => ContractPropValidator st Expectation+validateSuccess (res, _) = res `shouldSatisfy` isRight++-- | 'ContractPropValidator' that expects contract execution to+-- succeed and update storage to a particular constant value.+validateStorageIs+  :: IsoValue st+  => st -> ContractPropValidator (ToT st) Assertion+validateStorageIs expected (res, _) =+  case res of+    Left err ->+      assertFailure $ "Unexpected interpretation failure: " +| err |+ ""+    Right (_ops, got) ->+      got @?= toVal expected++-- | 'ContractPropValidator' that expects a given failure.+validateMichelsonFailsWith+  :: forall v st. NiceConstant v+  => v -> ContractPropValidator st Expectation+validateMichelsonFailsWith v (res, _) = case res of+  Right _ -> assertFailure $+    "contract was expected to fail with " +| expected |+ " but didn't."+  Left MichelsonFailureWithStack{..} -> mfwsFailed `shouldBe` expected+  where+    expected = MichelsonFailedWith (toVal v) \\ niceConstantEvi @v
+ src/Test/Cleveland/Tasty.hs view
@@ -0,0 +1,64 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module allows the use of "Test.Cleveland" tests in @tasty@.+--+-- These tests can be run on:+--+-- * the "Morley.Michelson.Runtime" emulator using+--   'testScenarioOnEmulator'/@scenarioEmulated@+-- * both on the emulator and a real Tezos network using+--   'testScenario'/@scenario@.+--+-- 'whenNetworkEnabled' can be used to write tests that need+-- to run a Tezos network, but are not necessarily written using "Test.Cleveland".+--+-- If a @TestTree@ contains many tests scheduled to run on a real Tezos network,+-- those tests will be run sequentially.+--+-- Example:+--+-- > import Test.Cleveland+-- > import Test.Cleveland.Tasty+-- >+-- > main :: IO ()+-- > main = clevelandMain test+-- >+-- > test :: TestTree+-- > test = testScenario "storage is 1" $ scenario do+-- >   addr <- originate OriginateData {..}+-- >   getStorage addr @@== 1+--+-- A cleveland/tasty test suite can be run in one of three modes, by setting either the @--cleveland-mode@+-- command line option or the @TASTY_CLEVELAND_MODE@ environment variable to:+--+-- * @all@ - runs all tests: non-cleveland tests, cleveland emulator tests and cleveland network tests.+-- * @disable-network@ - skips cleveland network tests.+-- * @only-network@ - runs only cleveland network tests and skips all other tests.+--+-- In a CI environment (i.e. if the @CI@ environment variable is set to @true@ (case-insensitive) or @1@),+-- the default mode is @all@.+--+-- Otherwise, the default mode is @disable-network@.+module Test.Cleveland.Tasty+  (+  -- * Main+    clevelandMain+  , clevelandMainWithIngredients+  , clevelandIngredients+  , loadTastyEnv++  -- * Test cases+  , testScenario+  , testScenarioOnEmulator+  , testScenarioOnNetwork++  , whenNetworkEnabled++  -- * Reading/setting options+  , modifyNetworkEnv+  , setAliasPrefix+  ) where++import Test.Cleveland.Tasty.Internal
+ src/Test/Cleveland/Tasty/Internal.hs view
@@ -0,0 +1,435 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ+{-# LANGUAGE InstanceSigs #-}++-- | This module is the internal implementation of "Test.Cleveland.Tasty".+module Test.Cleveland.Tasty.Internal+  (+  -- * Main+    clevelandMain+  , clevelandMainWithIngredients+  , clevelandIngredients+  , loadTastyEnv++  -- * Test cases+  , testScenario+  , testScenarioOnEmulator+  , testScenarioOnNetwork++  , whenNetworkEnabled++  -- * Reading/setting options+  , modifyNetworkEnv+  , setAliasPrefix++  -- * Internals+  , RunOnNetwork(..)+  , RunOnEmulator(..)+  , tastyEnvFromOpts+  , onNetworkTag+  , TastyEnvOpt(..)+  , TastyEnv(..)+  , mkTastyEnv+  , mapTastyEnv+  , memoize+  , loadOptionSwitcher+  ) where++import Control.Concurrent (modifyMVar, withMVar)+import qualified Data.Char as C+import Data.Tagged (Tagged(Tagged))+import Fmt (pretty)+import System.Environment (lookupEnv)+import qualified System.IO.Unsafe as Unsafe+import Test.Tasty+  (TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients,+  includingOptions, localOption, testGroup)+import Test.Tasty.Ingredients (Ingredient)+import Test.Tasty.Options (IsOption(..), OptionSet, lookupOption)+import Test.Tasty.Patterns.Types as Tasty (Expr(..))+import Test.Tasty.Providers (IsTest(..), Progress, singleTest, testFailed, testPassed)+import Test.Tasty.Runners (Result(..), TestPattern(..), TestTree(AskOptions))++import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv)+import Morley.Client.TezosClient.Types (tceAliasPrefixL)+import Test.Cleveland.Internal.Client as Client+  (ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT)+import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack))+import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT)+import Test.Cleveland.Internal.Scenario+import Test.Cleveland.Tasty.Internal.Options+  (AliasPrefixOpt(..), ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..),+  PathOpt(..), RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions)+import Test.Cleveland.Tasty.Internal.Report (formatError)++-- | A name that we use to tag all tests that run on the network.+--+-- We use this in a tasty @--pattern@ in .gitlab-ci.yml to run only network tests.+onNetworkTag :: TestName+onNetworkTag = "On network"++-- | Create a tasty test case from a 'Scenario'.+--+-- This will create a test tree with 2 tests:+-- one that runs the 'Scenario' on the "Morley.Michelson.Runtime" emulator,+-- and another that runs it on a real Tezos network.+--+-- The network config is read from the command line/environment variables.+-- Use @--help@ to see the available options.+--+-- If a 'TestTree' contains many tests scheduled to run on a real Tezos network,+-- those tests will be run sequentially.+testScenario :: TestName -> (forall m. Monad m => Scenario m) -> TestTree+testScenario testName scenario' =+  testGroup testName+    [ singleTest "On emulator" (RunOnEmulator scenario')+    , singleTest onNetworkTag (RunOnNetwork scenario')+    ]++-- | Create a tasty test case from an emulated 'Scenario'.+--+-- This will create a test tree with 1 test,+-- which will run the 'Scenario' on the "Morley.Michelson.Runtime" emulator.+testScenarioOnEmulator ::  TestName -> Scenario PureM -> TestTree+testScenarioOnEmulator testname scenario' =+  testGroup testname+    [ singleTest "On emulator" (RunOnEmulator scenario') ]++-- | Create a tasty test case from a 'Scenario'.+--+-- This will create a test tree with 1 test,+-- which will run the 'Scenario' on real Tezos network.+testScenarioOnNetwork ::  TestName -> Scenario ClientM -> TestTree+testScenarioOnNetwork testname scenario' =+  testGroup testname+    [ singleTest onNetworkTag (RunOnNetwork scenario') ]++newtype RunOnEmulator = RunOnEmulator (Scenario PureM)++instance IsTest RunOnEmulator where+  run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result+  run opts (RunOnEmulator scenario') _ = do+    let+      MoneybagAliasOpt moneybagAlias = lookupOption opts+      io = case scenario' of+              ScenarioCleveland s -> Pure.runClevelandT moneybagAlias s+              ScenarioEmulated s -> Pure.runEmulatedT moneybagAlias s+    (io $> testPassed "") `catch` printFormattedException opts++  testOptions = Tagged clevelandOptions++newtype RunOnNetwork = RunOnNetwork (Scenario ClientM)++instance IsTest RunOnNetwork where+  run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result+  run opts (RunOnNetwork (ScenarioCleveland clevelandT)) _ = do+    let+      tastyEnv = tastyEnvFromOpts opts+    useNetworkEnv tastyEnv $ \networkEnv -> do+      let io = Client.runClevelandT networkEnv clevelandT+      (io $> testPassed "") `catch` printFormattedException opts++  -- If a 'RunOnNetwork' test is created somewhere in a suite,+  -- these options will be automatically added to tasty's @--help@.+  testOptions = Tagged clevelandOptions++printFormattedException :: OptionSet -> SomeException -> IO Result+printFormattedException opts se =+  case fromException @WithCallStack se of+    Nothing ->+      pure (testFailed $ displayException se)++    Just (WithCallStack cs ex) -> do+      msg <- formatError contextLines cs (displayException ex)+      pure (testFailed (pretty msg))+  where+    ContextLinesOpt contextLines = lookupOption opts++-- | A global mutex to ensure only one cleveland test is executed at a time.+--+-- TODO: Remove this when #399 is done.+-- https://gitlab.com/morley-framework/morley/-/issues/399+--+-- See also: https://wiki.haskell.org/Top_level_mutable_state+lock :: MVar ()+lock = Unsafe.unsafePerformIO (newMVar ())+{-# NOINLINE lock #-}++----------------------------------------------------------------------------+-- Main+----------------------------------------------------------------------------++-- | Similar to @tasty@ @defaultMain@, but also preloads 'TastyEnv' and+-- registers the necessary command line options/environment variables to configure+-- "Test.Cleveland".+clevelandMain :: TestTree -> IO ()+clevelandMain = clevelandMainWithIngredients defaultIngredients . loadTastyEnv++-- | Similar to 'defaultMainWithIngredients', but also preloads 'TastyEnv' and+-- registers the necessary command line options/environment variables to configure+-- "Test.Cleveland".+clevelandMainWithIngredients :: [Ingredient] -> TestTree -> IO ()+clevelandMainWithIngredients ingredients tree = do+  ciSwitch <- withinCI+  defaultMainWithIngredients+    (clevelandIngredients <> ingredients)+    (loadOptionSwitcher ciSwitch . loadTastyEnv $ tree)++-- | A list with all the ingredients necessary to configure "Test.Cleveland".+--+-- Note: If a test suite uses 'Scenario', the relevant command line options+-- will be automatically added to tasty's @--help@.+--+-- However, if a test suite intends to not use those functions, and use 'whenNetworkEnabled'+-- only, then the CLI options need to be registered manually by using this ingredient+-- (or 'clevelandMain'/'clevelandMainWithIngredients').+clevelandIngredients :: [Ingredient]+clevelandIngredients =+  [ includingOptions clevelandOptions+  ]++----------------------------------------------------------------------------+-- Reading/setting options+----------------------------------------------------------------------------++-- | Creates a 'TastyEnv' from the passed command line/environment options.+tastyEnvFromOpts :: OptionSet -> TastyEnv+tastyEnvFromOpts optionSet =+  let+    AliasPrefixOpt aliasPrefix = lookupOption optionSet+    EndpointOpt endpoint = lookupOption optionSet+    PathOpt path = lookupOption optionSet+    DataDirOpt dataDir = lookupOption optionSet+    VerboseOpt verbosity = lookupOption optionSet+    SecretKeyOpt sk = lookupOption optionSet+    MoneybagAliasOpt origAlias = lookupOption optionSet+  in+    case lookupOption @TastyEnvOpt optionSet of+      -- If 'TastyEnv' has been already loaded and cached, use it.+      TastyEnvOpt (Just tastyEnv) -> tastyEnv+      -- Otherwise, load it.+      TastyEnvOpt Nothing -> mkTastyEnv $ do+        morleyClientEnv <- mkMorleyClientEnv MorleyClientConfig+          { mccAliasPrefix = aliasPrefix+          , mccEndpointUrl = endpoint+          , mccTezosClientPath = path+          , mccMbTezosClientDataDir = dataDir+          , mccVerbosity = verbosity+          , mccSecretKey = Nothing+          }+        pure NetworkEnv+            { neMorleyClientEnv = morleyClientEnv+            , neSecretKey = sk+            , neMoneybagAlias = origAlias+            }++-- | Heuristics to check whether we are running within CI.+-- Check the respective env variable which is usually set in all CIs.+withinCI :: IO Bool+withinCI = lookupEnv "CI" <&> \case+  Just "1"                       -> True+  Just (map C.toLower -> "true") -> True+  _                              -> False+{-# NOINLINE withinCI #-}++-- | Runs some tests only when network tests are enabled+-- (i.e., when running in the CI or when @--cleveland-mode all@).+--+-- Do not use this with a cleveland test (e.g. with 'testScenario'), as it will+-- lead to a [deadlock](https://gitlab.com/morley-framework/morley/-/issues/728).+-- This is only suitable for HUnit/Hspec/Hedgehog/etc tests.+--+-- Example usage:+--+-- > test :: TestTree+-- > test =+-- >   whenNetworkEnabled $ \withEnv ->+-- >     testCase "a test name" $+-- >       withEnv $ \env ->+-- >         runMorleyClientM (neMorleyClientEnv env) $ do+-- >           ...+whenNetworkEnabled :: ((forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree) -> TestTree+whenNetworkEnabled mkTestTree =+  AskOptions \optionSet ->+    let TastyEnv useNetworkEnv = tastyEnvFromOpts optionSet+      in testGroup onNetworkTag [ mkTestTree useNetworkEnv ]++-- | Modifies the 'NetworkEnv' for all the tests in the given test tree.+modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree+modifyNetworkEnv f tree =+  AskOptions \optionSet ->+  let tastyEnv = tastyEnvFromOpts optionSet+    in localOption (TastyEnvOpt $ Just (mapTastyEnv f tastyEnv)) $+         tree++-- | Overrides the alias prefix (parsed from @--cleveland-alias-prefix@ or @TASTY_CLEVELAND_ALIAS_PREFIX@)+-- for all the tests in the given test tree.+setAliasPrefix :: Text -> TestTree -> TestTree+setAliasPrefix aliasPrefix tree =+  modifyNetworkEnv (neMorleyClientEnvL.mceTezosClientL.tceAliasPrefixL .~ Just aliasPrefix) $+    tree++----------------------------------------------------------------------------+-- Preload TastyEnv+----------------------------------------------------------------------------++-- | A pre-loaded 'TastyEnv'.+--+-- It's not an actual command line option, we use it+-- so we can load a 'TastyEnv' once, and then cache it+-- alongside the other options in tasty's 'OptionSet'.+--+-- Kiiiind of a hack, but it works :D+--+-- It is purposefully never registered as a CLI option+-- (e.g. using 'Test.Tasty.Providers.testOptions' or 'Test.Tasty.includingOptions')+-- to make sure it doesn't appear in tasty's @--help@.+newtype TastyEnvOpt = TastyEnvOpt (Maybe TastyEnv)++instance IsOption TastyEnvOpt where+  defaultValue = TastyEnvOpt Nothing+  optionName = ""+  optionHelp = ""+  parseValue = \_ -> Nothing++-- | Pre-load 'TastyEnv' from the passed command line/environment options,+-- and store it in tasty's 'OptionSet' to make it available to+-- all tests within the test tree.+--+-- Creating a 'NetworkEnv' is a relatively expensive operation, when executed hundreds of times.+-- This function guarantees that only one 'TastyEnv' is created for this test tree, and+-- 'TastyEnv' will, in turn, guarantee that only one 'NetworkEnv' is created while the tests are running.+loadTastyEnv :: TestTree -> TestTree+loadTastyEnv tree =+  AskOptions \optionSet ->+    let tastyEnv = tastyEnvFromOpts optionSet+    in localOption (TastyEnvOpt $ Just tastyEnv)+         tree++----------------------------------------------------------------------------+-- TastyEnv+----------------------------------------------------------------------------++-- | This action will:+--+-- 1. Enter a critical section+-- 2. Either:+--+--     * Create a 'NetworkEnv' and cache it, if it's the first time being evaluated.+--     * Or reuse an existing cached 'NetworkEnv' otherwise.+--+-- 3. Pass it to the given @networkEnv -> IO a@ function.+-- 4. Exit the critical section+--+-- This ensures:+--+-- * 'NetworkEnv' is only created once (it's a relatively expensive operation).+-- * tests that use 'NetworkEnv' are run sequentially+--    (see #399, https://gitlab.com/morley-framework/morley/-/issues/399)+newtype TastyEnv = TastyEnv+  { useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a+  }++mkTastyEnv :: IO NetworkEnv -> TastyEnv+mkTastyEnv mkEnv =+  TastyEnv+    { useNetworkEnv = \cont ->+        withMVar lock $ \() -> do+          env <- memoMkEnv+          cont env+    }+  where+    -- Note: Using `unsafePerformIO` here is the recommended workaround for+    -- not being able to use IO inside `askOption`/`AskOptions`.+    -- https://github.com/feuerbach/tasty/issues/228+    --+    -- We're only using it here to initialize an 'MVar', so it /should/ be safe 🤞+    memoMkEnv = Unsafe.unsafePerformIO $ memoize mkEnv++mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> (TastyEnv -> TastyEnv)+mapTastyEnv g (TastyEnv f) =+  TastyEnv $ \cont ->+    f (\networkEnv -> cont (g networkEnv))++-- | A thread-safe, lazy, write-once cache.+--+-- >>> action <- memoize (putStrLn "hello" $> 3)+-- >>> action+-- hello+-- 3+-- >>> action+-- 3+memoize :: forall a. IO a -> IO (IO a)+memoize action = do+  -- The implementation is very similar to 'once' from @io-memoize@.+  -- https://hackage.haskell.org/package/io-memoize-1.1.1.0/docs/System-IO-Memoize.html+  cache <- newMVar Nothing++  let+    readCache :: IO a+    readCache =+      readMVar cache >>= \case+        Just a -> pure a+        Nothing ->+          modifyMVar cache $ \case+            Just a -> pure (Just a, a)+            Nothing -> do+              a <- action+              pure (Just a, a)++  pure readCache++----------------------------------------------------------------------------+-- Custom @TestPattern@s+----------------------------------------------------------------------------++-- | Helper that checks which environment variables / command line options are set,+-- and filters TestTree to run tests according to the decision table+-- at the top of this module.+loadOptionSwitcher :: Bool -> TestTree -> TestTree+loadOptionSwitcher ciFlag testTree =+  askOption @RunModeOpt $ \mode -> case (mode, ciFlag) of+    (RunAllMode, _) -> testTree+    (OnlyNetworkMode, _) -> loadOnlyNetworkPattern testTree+    (DisableNetworkMode, _) -> loadNoNetworkPattern testTree+    (DefaultMode, False) -> loadNoNetworkPattern testTree+    (DefaultMode, True) -> testTree+  where+     loadOnlyNetworkPattern :: TestTree -> TestTree+     loadOnlyNetworkPattern = adjustOption (adjustExprToTestPattern runOnlyNetworkExpr)++     loadNoNetworkPattern :: TestTree -> TestTree+     loadNoNetworkPattern = adjustOption (adjustExprToTestPattern dontRunNetworkExpr)++     adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern+     adjustExprToTestPattern expr (TestPattern maybePattern) = TestPattern $ Just+       case maybePattern of+         Nothing -> expr+         Just ptrn -> And ptrn expr++-- | Pattern that enables only network tests, all emulator tests will be disabled.+--+-- Tasty pattern eDSL version of+-- "$1 == \"On network\" || $NF == \"On network\" || $0 ~ /.On network./"+runOnlyNetworkExpr :: Expr+runOnlyNetworkExpr =+  Or+    (Or+      (Tasty.EQ (Field (IntLit 1)) (StringLit "On network"))+      (Tasty.EQ (Field NF) (StringLit "On network"))+    )+    (Match (Field (IntLit 0)) ".On network.")++-- | Pattern that disables all network tests, all other tests will be enabled.+--+-- Tasty pattern eDSL version of+-- "$1 != \"On network\" && $NF != \"On network\" && $0 !~ /.On network./"+dontRunNetworkExpr :: Expr+dontRunNetworkExpr =+  And+    (And+      (Tasty.NE (Field (IntLit 1)) (StringLit "On network"))+      (Tasty.NE (Field NF) (StringLit "On network"))+    )+    (NoMatch (Field (IntLit 0)) ".On network.")
+ src/Test/Cleveland/Tasty/Internal/Options.hs view
@@ -0,0 +1,252 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module declares all options/flags that @tasty@ will+-- parse from the command line/environment variables.+--+-- They're used to configure "Test.Cleveland".+module Test.Cleveland.Tasty.Internal.Options+  ( clevelandOptions+  , AliasPrefixOpt(..)+  , MoneybagAliasOpt(..)+  , EndpointOpt(..)+  , PathOpt(..)+  , DataDirOpt(..)+  , VerboseOpt(..)+  , SecretKeyOpt(..)+  , RunModeOpt(..)+  , ContextLinesOpt(..)+  ) where++import Control.Monad.Except (runExcept)+import Data.Tagged (untag)+import qualified Options.Applicative as Opt+import Options.Applicative.Types (Parser, ReadM(..))+import Servant.Client.Core (BaseUrl(..))+import Test.Tasty.Options as Tasty (IsOption(..), OptionDescription(Option), safeRead)++import Morley.Client (Alias, mkAlias)+import Morley.Client.Parser (baseUrlReader)+import qualified Morley.Tezos.Crypto as Crypto+import Morley.Util.CLI (HasCLReader(getMetavar, getReader))++-- $defaultValues+--+-- Tasty will use 'optionCLParser' to attempt to parse options from the command line.+-- If it fails, it will try to parse them from environment variables instead (using 'parseValue').+--+-- For this reason, it's important that 'optionCLParser' is NOT a parser+-- that /always/ succeeds. If it is, tasty will not attempt to read environment variables.+--+-- From the [docs](http://hackage.haskell.org/package/tasty-1.3.1/docs/Test-Tasty-Options.html#v:optionCLParser):+--+-- > Do not supply a default value (e.g., with the value function) here for this parser!+-- > This is because if no value was provided on the command line we may lookup the option e.g.+-- > in the environment. But if the parser always succeeds, we have no way to tell+-- > whether the user really provided the option on the command line.+++-- | A list with all the options needed to configure "Test.Cleveland".+clevelandOptions :: [OptionDescription]+clevelandOptions =+  [ Tasty.Option (Proxy @AliasPrefixOpt)+  , Tasty.Option (Proxy @EndpointOpt)+  , Tasty.Option (Proxy @PathOpt)+  , Tasty.Option (Proxy @DataDirOpt)+  , Tasty.Option (Proxy @VerboseOpt)+  , Tasty.Option (Proxy @SecretKeyOpt)+  , Tasty.Option (Proxy @MoneybagAliasOpt)+  , Tasty.Option (Proxy @RunModeOpt)+  , Tasty.Option (Proxy @ContextLinesOpt)+  ]++----------------------------------------------------------------------------+-- Morley Client options+----------------------------------------------------------------------------++newtype AliasPrefixOpt = AliasPrefixOpt (Maybe Text)+  deriving stock (Show, Eq)++instance IsOption AliasPrefixOpt where+  defaultValue = AliasPrefixOpt Nothing+  optionName = "cleveland-alias-prefix"+  optionHelp = "[Test.Cleveland] A prefix to prepend to every alias created " <>+               "with 'newAddress' or 'newFreshAddress'."+  parseValue = mkParseValue (AliasPrefixOpt . Just)+  optionCLParser = mkOptionParser (AliasPrefixOpt . Just) Nothing++-- | Morley Client option specifying endpoint URL of the Tezos node.+newtype EndpointOpt = EndpointOpt (Maybe BaseUrl)+  deriving stock (Show, Eq)++instance IsOption EndpointOpt where+  defaultValue = EndpointOpt Nothing+  optionName = "cleveland-node-endpoint"+  optionHelp = "[Test.Cleveland] Remote node endpoint URL"+  parseValue = mkParseValueWithReadM baseUrlReader (EndpointOpt . Just)+  optionCLParser =+    mkOptionParserWithReadM baseUrlReader "URL" (EndpointOpt . Just) (Just 'E')++newtype PathOpt = PathOpt FilePath+  deriving stock (Show, Eq)++instance IsOption PathOpt where+  defaultValue = PathOpt "tezos-client"+  optionName = "cleveland-client-path"+  optionHelp = "[Test.Cleveland] Path to tezos-client binary"+  parseValue = mkParseValue PathOpt+  optionCLParser = mkOptionParser PathOpt (Just 'I')++newtype DataDirOpt = DataDirOpt (Maybe FilePath)+  deriving stock (Show, Eq)++instance IsOption DataDirOpt where+  defaultValue = DataDirOpt Nothing+  optionName = "cleveland-data-dir"+  optionHelp = "[Test.Cleveland] Path to tezos-client data directory"+  parseValue = mkParseValue (DataDirOpt . Just)+  optionCLParser = mkOptionParser (DataDirOpt . Just) (Just 'd')++-- | To increase verbosity, pass @-V@ several times on the command line (e.g. @-VVV@),+-- or set @TASTY_CLEVELAND_VERBOSE=3@ as an environment variable.+newtype VerboseOpt = VerboseOpt Word+  deriving stock (Show, Eq)++instance IsOption VerboseOpt where+  defaultValue = VerboseOpt 0+  optionName = "cleveland-verbose"+  optionHelp = "[Test.Cleveland] Increase verbosity (pass several times to increase further)"+  parseValue = \str -> VerboseOpt <$> safeRead str+  optionCLParser =+    -- See: $defaultValues+    --+    -- Therefore, we use `some` instead of `many` here.+    -- `some` will fail if "-V" is absent, and then tasty will attempt+    -- to parse the "TASTY_CLEVELAND_VERBOSE" env variable instead.+    VerboseOpt . genericLength <$> some flag+    where+      flag =+        Opt.flag' () . mconcat $+          [ Opt.short 'V'+          , Opt.long (untag (optionName @VerboseOpt))+          , Opt.help (untag (optionHelp @VerboseOpt))+          ]++----------------------------------------------------------------------------+-- cleveland options+----------------------------------------------------------------------------++newtype SecretKeyOpt = SecretKeyOpt (Maybe Crypto.SecretKey)+  deriving stock (Show, Eq)++instance IsOption SecretKeyOpt where+  defaultValue = SecretKeyOpt Nothing+  optionName = "cleveland-moneybag-secret-key"+  optionHelp = "[Test.Cleveland] Secret key of the account to be used to execute all transfers/originations " <>+               "(unless overriden with `withSender`) and fund new accounts (unless overriden with `withMoneybag`)."+  parseValue = mkParseValue (SecretKeyOpt . Just)+  optionCLParser = mkOptionParser (SecretKeyOpt . Just) Nothing++newtype MoneybagAliasOpt = MoneybagAliasOpt Alias+  deriving stock (Show, Eq)+++instance IsOption MoneybagAliasOpt where+  defaultValue = MoneybagAliasOpt $ mkAlias "moneybag"+  optionName = "cleveland-moneybag-alias"+  optionHelp = "[Test.Cleveland] Alias of the account to be used to execute all transfers/originations " <>+               "(unless overriden with `withSender`) and fund new accounts (unless overriden with `withMoneybag`)."+  parseValue = Just . MoneybagAliasOpt . mkAlias . fromString++data RunModeOpt+  = RunAllMode+  | OnlyNetworkMode+  | DisableNetworkMode+  | DefaultMode++instance IsOption RunModeOpt where+  defaultValue = DefaultMode+  optionName = "cleveland-mode"+  optionHelp =+    "[Test.Cleveland] Determines whether tests on a Tezos network\+    \and Morley.Michelson emulator should run. \+    \The following modes are supported:\+    \ 1) 'all' — run both network and emulator tests. Also, all non-cleveland \+    \    tests are run as well.\+    \ 2) 'only-network' — run only network tests, this mod is a short version of\+    \   '--pattern \"$1 == \"On network\" || $NF == \"On network\" || $0 ~ /.On network./\"'.\+    \   Non-cleveland tests will be disabled as well.\+    \ 3) 'disable-network' — disable network tests and run only emulator\+    \    and non-cleveland tests.\+    \\+    \In case no mode is provided, the behaviour of this option depends on whether\+    \the 'CI' environment variable is set: \+    \ * In case 'CI' is set, the default behaviour is 'all'\+    \ * In case 'CI' is unset, the default behaviour is 'disable-network'"+  parseValue str = case str of+    "all" -> Just RunAllMode+    "only-network" -> Just OnlyNetworkMode+    "disable-network" -> Just DisableNetworkMode+    _ -> Nothing++newtype ContextLinesOpt = ContextLinesOpt Natural+  deriving stock (Show, Eq)++instance IsOption ContextLinesOpt where+  defaultValue = ContextLinesOpt 5+  optionName = "cleveland-context-lines"+  optionHelp = "[Test.Cleveland] Number of source code lines to show around an error when a test fails"+  parseValue = mkParseValue ContextLinesOpt+  optionCLParser = mkOptionParser ContextLinesOpt Nothing++----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++-- Create an environment variable parser for types that don't have a+-- 'HasCLReader' instance to avoid adding an unnecessary dependency.+mkParseValueWithReadM :: forall v a. ReadM a -> (a -> v) -> String -> Maybe v+mkParseValueWithReadM readm wrap =+  fmap wrap . rightToMaybe . runExcept . runReaderT (unReadM readm)++-- | Create an environment variable parser by reusing an instance of `HasCLReader`.+mkParseValue+  :: forall v a+  .  HasCLReader a+  => (a -> v)+  -> String+  -> Maybe v+mkParseValue = mkParseValueWithReadM (getReader @a)++-- | Build a command line option parser by reusing an instance of `IsOption`,+-- for types that don't have an instance of 'HasCLReader'.+mkOptionParserWithReadM+  :: forall v a+  .  IsOption v+  => ReadM a+  -> String -- ^ metavar+  -> (a -> v)+  -> Maybe Char+  -> Parser v+mkOptionParserWithReadM readm metav wrap shortMb =+  wrap <$> Opt.option readm mods+  where+    -- See: $defaultValues+    --+    -- Therefore, we never specify a default value here.+    mods = mconcat+      [ Opt.metavar metav+      , maybe mempty Opt.short shortMb+      , Opt.long (untag (optionName @v))+      , Opt.help (untag (optionHelp @v))+      ]++-- | Build a command line option parser by reusing instances of `HasCLReader` and `IsOption`+mkOptionParser+  :: forall v a+  .  (IsOption v, HasCLReader a)+  => (a -> v)+  -> Maybe Char+  -> Parser v+mkOptionParser = mkOptionParserWithReadM (getReader @a) (getMetavar @a)
+ src/Test/Cleveland/Tasty/Internal/Report.hs view
@@ -0,0 +1,195 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Pretty-printers for reports in Tasty logs.+module Test.Cleveland.Tasty.Internal.Report+  ( formatError+  ) where++import Data.Char (isPrint, isSpace)+import Data.Ix (Ix(inRange))+import qualified Data.List as List+import qualified Data.Text.IO.Utf8 as Utf8+import Fmt (Buildable(build), Builder, indentF, padLeftF, unlinesF, (+|), (|+))+import GHC.Stack (SrcLoc(..))+import System.Directory (makeRelativeToCurrentDirectory)+import System.IO.Error+  (IOError, catchIOError, ioError, isAlreadyInUseError, isDoesNotExistError, isPermissionError)+import qualified Unsafe++-- HLint wrongfully thinks we are not using these things from universum,+-- perhaps because of morley-prelude.+{-# ANN module ("HLint: ignore Use 'getCallStack' from Universum" :: Text) #-}+{-# ANN module ("HLint: ignore Use 'prettyCallStack' from Universum" :: Text) #-}+++{-+Note [Cleveland & callstacks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Cleveland's reports are very similar to Hedgehog's. They both:+  1. Display the source code line where the error occurred and some context around it.+  2. Display the error message right below the offending line.++However, there are some notable differences:+  1. Cleveland shows (by default) 5 lines before and after the error location,+     whereas Hedgehog is smarter and displays the full top-level declaration.+      * The number of lines to display can be configured with `--cleveland-context-lines`.+      * This decision was made because tasty tests are sometimes embedded in a (much)+        larger test tree, and displaying the whole top-level declaration would add+        a lot of clutter and make the report unreadable.++  2. Cleveland displays the full callstack at the bottom, with the filepath/line/column.+     This is helpful because in some editors/terminals, you can click on the filepath+     link and have the editor jump straight to that location in the source code.++  3. Hedgehog displays the source code for all callstack frames and annotates the top-most+     frame with the error message, whereas Cleveland displays only the bottom-most frame.++-}++-- | Pretty-prints an error by displaying:+--+-- * the source code where the error occurred+-- * the expression that threw the error+-- * an associated error message below said expression+-- * the error's callstack+formatError+  :: Natural -- ^ The number of source code lines to print before and after the location of the error+  -> CallStack -- ^ The error's callstack+  -> String -- ^ The error message to display below the expression that caused the error+  -> IO Builder+formatError contextLines cstack errMsg = do+  case getLocation cstack of+    Nothing -> pure $ build errMsg+    Just loc -> flip catchIOError handleIOError do+      path <- makeRelativeToCurrentDirectory (srcLocFile loc)+      fileLines <- numbered . lines <$> Utf8.readFile path++      let (beforeLines, errorLines, afterLines) = linesAround contextLines loc fileLines++      -- Calculate how many digits we need to display line numbers.+      -- If we're about to display lines 9 to 101, then we need 3 digits total.+      let lineNumberPadding =+            length . show @Text . maximum $ lineNumber <$>+              (beforeLines `appendNE` errorLines `prependNE` afterLines)+          appendNE xs ys = maybe ys (<> ys) $ nonEmpty xs+          prependNE (x :| xs) ys = x :| (xs <> ys)++      pure $ unlinesF $+        [ headerF lineNumberPadding path ]+        <> (srcLineF lineNumberPadding <$> beforeLines)+        <> (srcLineF lineNumberPadding <$> toList errorLines)+        <> errorMsgF lineNumberPadding loc errorLines errMsg+        <> (srcLineF lineNumberPadding <$> afterLines)+        <> ["", build (prettyCallStack cstack)]+  where+    handleIOError :: IOError -> IO Builder+    handleIOError err =+      if isAlreadyInUseError err || isDoesNotExistError err || isPermissionError err+        then pure $ unlinesF $+          [ errMsg+          , ""+          , prettyCallStack cstack+          ]+        else ioError err++getLocation :: CallStack -> Maybe SrcLoc+getLocation = fmap snd . safeLast . getCallStack+  where+    safeLast = \case+      [] -> Nothing+      l -> Just $ Unsafe.last l++data Line = Line+  { lineText :: Text+  , lineNumber :: Int+  }++-- | Attach line numbers to each line of source code.+numbered :: [Text] -> [Line]+numbered texts = uncurry Line <$> (texts `zip` [1..])++-- | Given a list of source code lines, returns:+--+-- * the @n@ lines that preceed the location of the error+-- * the line(s) where the error occurred+-- * the @n@ lines that follow the location of the error+linesAround :: Natural -> SrcLoc -> [Line] -> ([Line], NonEmpty Line, [Line])+linesAround (Unsafe.fromIntegral @_ @Int -> n) loc xs =+  ( beforeLines+  , Unsafe.fromJust $ nonEmpty errorLines -- <- errorLines is guaranteed to always have at least 1 line+  , afterLines+  )+  where+    beforeLines = filter (\l -> (srcLocStartLine loc - n , srcLocStartLine loc - 1) `inRange` (lineNumber l)) xs+    errorLines  = filter (\l -> (srcLocStartLine loc     , srcLocEndLine loc      ) `inRange` (lineNumber l)) xs+    afterLines  = filter (\l -> (srcLocEndLine loc + 1   , srcLocEndLine loc + n  ) `inRange` (lineNumber l)) xs++----------------------------------------------------------------------------+-- Formatters+----------------------------------------------------------------------------++verticalBorder :: Builder+verticalBorder = " ┃ "++headerF :: Int -> FilePath -> Builder+headerF lineNumberPadding path =+  indentF lineNumberPadding $+    " ┏━━ " +| path |+ " ━━━"++srcLineF :: Int -> Line -> Builder+srcLineF lineNumberPadding line =+  padLeftF lineNumberPadding ' ' (lineNumber line) +| verticalBorder +| build (lineText line)++errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> String -> [Builder]+errorMsgF lineNumberPadding loc errorLines errMsg =+  indentF lineNumberPadding . addPadding <$>+    (carets : errLines)+  where+    (startColumn, endColumn) = caretColumns loc errorLines++    addPadding :: Builder -> Builder+    addPadding line =+      verticalBorder +| indentF (startColumn - 1) line++    carets :: Builder+    carets = build $ replicate (endColumn - startColumn) '^'++    errLines :: [Builder]+    errLines = List.lines errMsg <&> \line ->+      "| " +| build line++-- | Calculates the start and end columns for drawing carets (^).+--+-- If the expression that caused the error is in a single line,+-- then we can simply use the column numbers from 'SrcLoc'.+--+-- However, if the expression spans 2 or more lines, then it's a bit more complicated.+-- For example, say we have this expression:+--+-- > someFunc+-- >  arg+--+-- Then 'SrcLoc'\'s start column will be 1 and end column will be 5.+-- However, we actually want the carets to be displayed from columns 1 to 9, like so:+--+-- > someFunc+-- >  arg+-- > ^^^^^^^^+--+-- See more examples in the @TestSuite.Cleveland.Tasty.Report.Examples@ module.+caretColumns :: SrcLoc -> NonEmpty Line -> (Int, Int)+caretColumns loc errorLines =+  ( minimum (srcLocStartCol loc :| fmap lineStartColumn (tail errorLines))+  , maximum (srcLocEndCol loc :| fmap lineEndColumn (init errorLines))+  )+  where+    lineEndColumn :: Line -> Int+    lineEndColumn (Line text _) =+      1 + length (filter isPrint (toString text))++    lineStartColumn :: Line -> Int+    lineStartColumn (Line text _) =+      1 + length (takeWhile isSpace (toString text))
+ src/Test/Cleveland/Util.hs view
@@ -0,0 +1,396 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Testing utility functions used by testing framework itself or+-- intended to be used by test writers.++module Test.Cleveland.Util+  ( leftToShowPanic+  , leftToPrettyPanic+  , (?-)++  -- * Property+  , failedTest+  , succeededTest+  , eitherIsLeft+  , eitherIsRight+  , meanTimeUpperBoundProp+  , meanTimeUpperBoundPropNF++  -- * Generator+  , genTuple2+  , genRandom+  , runGen++  -- * Roundtrip+  , roundtripTree+  , assertGoesBefore+  , goesBefore+  , partialParse++  -- * Pretty-printing+  , formatValue+  , formatSomeValue+  , ShowWith(..)+  , Showing(..)++  -- * Time+  , ceilingUnit+  , timeToFixed+  , timeToNominalDiffTime++  -- * Bytes+  , stripOptional0x+  , fromHex+  , unsafeFromHex++  -- * Traversals+  , mapEach+  , forEach++  -- * Re-exports+  --+  -- | These functions from @Time@ are re-exported here to make it convenient to call+  -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'.+  , mcs, ms, sec, minute+  ) where++import Control.Lens as L+import Control.Monad.Random (MonadRandom, evalRand, mkStdGen)+import Criterion (Benchmarkable, benchmarkWith', nf, whnf)+import Criterion.Main (defaultConfig)+import Criterion.Types (SampleAnalysis(anMean), Verbosity(Quiet), reportAnalysis, verbosity)+import Data.Fixed (Fixed, HasResolution)+import Data.Ratio ((%))+import Data.Singletons (demote)+import qualified Data.Text as T+import Data.Time (NominalDiffTime, secondsToNominalDiffTime)+import Data.Typeable (typeRep)+import Fmt (Buildable, Builder, build, pretty, (+|), (+||), (|+), (||+))+import Hedgehog+  (Gen, MonadGen, MonadTest, Property, annotate, evalIO, failure, forAll, property, success,+  tripping, withTests)+import qualified Hedgehog.Gen as Gen+import Hedgehog.Internal.Gen (runGenT)+import qualified Hedgehog.Internal.Seed as Seed+import Hedgehog.Internal.Tree (TreeT(runTreeT), nodeValue)+import qualified Hedgehog.Range as Range+import Morley.Michelson.Doc (DocItem, docItemPosition)+import Morley.Michelson.Typed (OpPresence(OpAbsent, OpPresent), SingI, SomeValue(..), sing)+import qualified Morley.Michelson.Typed as T+import Statistics.Types (Estimate(estPoint))+import Test.HUnit (Assertion, assertFailure)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.Hedgehog (testProperty)+import Text.Hex (decodeHex)+import Text.Printf (printf)+import qualified Text.Show+import Time+  (KnownDivRat, KnownUnitName, Microsecond, Millisecond, Minute, Nanosecond, Picosecond, Rat,+  RatioNat, Second, Time, mcs, minute, ms, ns, sec, time, timeout, toUnit, unTime, unitNameVal)++{-+Note [Hedgehog & withFrozenCallStack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When an Hedgehog test fails, Hedgehog displays the source code for all callstack frames,+and annotates the top-most frame with the error message.++When an assertion helper like `failedTest` fails, the helper itself will be the top-most frame.+This means that, under normal circumstances, Hedgehog would display the error message+next to `failedTest`'s source code, and **not** next to the user's source code.++In order to force Hedgehog to display the error message next to the user's source code,+we use `withFrozenCallStack` to effectively remove the assertion helper from the callstack.++On a side note: the reason why we don't need to use `withFrozenCallStack` in Cleveland's+assertion helpers is because Cleveland only displays the bottom-most callstack+frame (i.e., the user's source code).+See: Note [Cleveland & callstacks] for more information.+-}++leftToShowPanic :: (Show e, HasCallStack) => Either e a -> a+leftToShowPanic = either (error . show) id++leftToPrettyPanic :: (Buildable e, HasCallStack) => Either e a -> a+leftToPrettyPanic = either (error . pretty) id++-- | Make a tuple with name without extra syntactic noise.+(?-) :: Text -> a -> (Text, a)+(?-) = (,)+infixr 0 ?-++----------------------------------------------------------------------------+-- Property+----------------------------------------------------------------------------++-- | A 'Property' that always fails with given message.+failedTest :: (HasCallStack, MonadTest m) => Text -> m ()+failedTest r =+  -- See: Note [Hedgehog & withFrozenCallStack]+  withFrozenCallStack $ annotate (toString r) >> failure++-- | A 'Property' that always succeeds.+succeededTest :: MonadTest m => m ()+succeededTest = success++-- | The 'Property' holds on `Left a`.+eitherIsLeft :: (Show b, MonadTest m, HasCallStack) => Either a b -> m ()+eitherIsLeft = \case+  Left _ -> succeededTest+  Right x ->+    -- See: Note [Hedgehog & withFrozenCallStack]+    withFrozenCallStack $ failedTest $ "expected Left, got Right (" <> show x <> ")"++-- | The 'Property' holds on `Right b`.+eitherIsRight :: (Show a, MonadTest m, HasCallStack) => Either a b -> m ()+eitherIsRight = \case+  Right _ -> succeededTest+  Left x ->+    -- See: Note [Hedgehog & withFrozenCallStack]+    withFrozenCallStack $ failedTest $ "expected Right, got Left (" <> show x <> ")"++-- | Benchmarks the given function and checks that the mean time to evaluate to weak head+-- normal form is under the given amount of time.+--+-- This test fails if the benchmark takes longer than 30 seconds to run.+meanTimeUpperBoundProp+  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack)+  => Time unit -> (a -> b) -> a -> Property+meanTimeUpperBoundProp upperBound run arg =+  -- See: Note [Hedgehog & withFrozenCallStack]+  withFrozenCallStack $+    checkReport upperBound $ whnf run arg++-- | Benchmarks the given function and checks that the mean time to evaluate to+-- normal form is under the given amount of time.+--+-- This test aborts and fails if the benchmark takes longer than 120 seconds to run.+meanTimeUpperBoundPropNF+  :: (KnownDivRat unit Second, KnownUnitName unit, HasCallStack, NFData b)+  => Time unit -> (a -> b) -> a -> Property+meanTimeUpperBoundPropNF upperBound run arg =+  -- See: Note [Hedgehog & withFrozenCallStack]+  withFrozenCallStack $+    checkReport upperBound $ nf run arg++checkReport+  :: (KnownDivRat unit Second, KnownUnitName unit)+  => HasCallStack => Time unit -> Benchmarkable -> Property+checkReport upperBound benchmarkable =+  withTests 1 $ property $+    evalIO runBench >>= \case+      Nothing -> failedTest "Expected benchmark to complete within 120 seconds."+      Just report ->+        let mean = sec . realToFrac @Double @RatioNat . estPoint . anMean $ reportAnalysis report+        in  if mean < toUnit @Second upperBound+              then succeededTest+              else failedTest $+                "Expected mean estimate to be under "+                <> show upperBound+                <> ", but was "+                <> display mean+  where+    runBench = timeout (minute 2) $+      benchmarkWith' (defaultConfig { verbosity = Quiet }) benchmarkable++    display :: Time Second -> Text+    display n = case n of+      (toUnit @Minute -> x) | x > minute 1 -> format x+      (toUnit @Second -> x) | x > sec 1 -> format x+      (toUnit @Millisecond -> x) | x > ms 1 -> format x+      (toUnit @Microsecond -> x) | x > mcs 1 -> format x+      (toUnit @Nanosecond -> x) | x > ns 1 -> format x+      _ -> format (toUnit @Picosecond n)++    format :: forall unit. KnownUnitName unit => Time unit -> Text+    format n =+      toText @String $ printf "%.4f%s"+        (realToFrac @RatioNat @Double $ unTime n)+        (unitNameVal @unit)++----------------------------------------------------------------------------+-- Generator+----------------------------------------------------------------------------++-- | Generates an @a@ and a @b@ and wraps them in a tuple.+genTuple2 :: MonadGen m => m a -> m b -> m (a, b)+genTuple2 = liftA2 (,)++-- | Construct a hedgehog generator from a generator relying on 'MonadRandom'.+--+-- This neither shrinks nor generates values in a reasonable order,+-- use only when such properties are justified for your type.+genRandom :: MonadGen m => (forall n. MonadRandom n => n a) -> m a+genRandom gen = evalRand gen . mkStdGen <$> Gen.prune Gen.enumBounded++-- | Run the given generator deterministically, by fixing its size and seed.+runGen :: HasCallStack => Range.Size -> Word64 -> Gen a -> a+runGen size seed genT =+  let tree = runGenT size (Seed.from seed) genT+      node = fromMaybe discardedErr $ runIdentity $ runMaybeT $ runTreeT tree+      discardedErr = error $+        "Generator could not produce a value for size "+        <> show size <> " and seed " <> show seed+  in  nodeValue node++----------------------------------------------------------------------------+-- Roundtrip+----------------------------------------------------------------------------++-- | This 'TestTree' contains a property based test for conversion from+-- some @x@ to some @y@ and back to @x@ (it should successfully return+-- the initial @x@).+roundtripTree+  :: forall x y err.+     ( Show x+     , Show y+     , Show err+     , Typeable x+     , Eq x+     , Eq err+     , HasCallStack+     )+  => Gen x+  -> (x -> y)+  -> (y -> Either err x)+  -> TestTree+roundtripTree genX xToY yToX = testProperty typeNameX prop+  where+    typeNameX = show $ typeRep (Proxy @x)+    prop :: Property+    prop = property $ do+      x <- forAll genX+      tripping x xToY yToX++-- | Test that one doc item goes before another doc item in generated+-- documentation.+assertGoesBefore+  :: forall d1 d2.+      (DocItem d1, DocItem d2)+  => Proxy d1 -> Proxy d2 -> Assertion+assertGoesBefore dp1 dp2 =+  unless (p1 < p2) $+    assertFailure $+      "Doc item " <> show (typeRep dp1) <> " with position " <> pretty p1 <> " \+      \goes before doc item " <> show (typeRep dp2) <> " with position " <> pretty p2+  where+    p1 = docItemPosition @d1+    p2 = docItemPosition @d2++-- | Test that one doc item goes before another doc item in generated+-- documentation.+goesBefore+  :: forall d1 d2.+      (DocItem d1, DocItem d2)+  => Proxy d1 -> Proxy d2 -> TestTree+goesBefore dp1 dp2 = testCase testName (assertGoesBefore dp1 dp2)+  where+  testName = "`" +|| typeRep dp1 ||+ "` should come before `" +|| typeRep dp2 ||+ "`"++-- | Helper function for running parser in test environment+partialParse :: (HasCallStack, Buildable b) => (a -> Either b c) -> a -> c+partialParse f = either (error . pretty) id . f++----------------------------------------------------------------------------+-- Pretty-printing+----------------------------------------------------------------------------++formatValue :: forall t. SingI t => T.Value t -> Builder+formatValue v =+  case T.checkOpPresence (sing @t) of+    OpPresent -> show v+    OpAbsent -> "" +| build v |+ " of type " +| demote @t |+ ""++formatSomeValue :: SomeValue -> Builder+formatSomeValue (SomeValue v) = formatValue v++-- | Derive a 'Show' instance for a type using a custom "show" function.+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++-- | Derive a 'Buildable' instance for a type using 'show'.+newtype Showing a = Showing a+  deriving stock Eq+  deriving newtype Show++instance Show a => Buildable (Showing a) where+  build (Showing a) = build (show @Text a)++----------------------------------------------------------------------------+-- Time+----------------------------------------------------------------------------++-- | Round the given time to the nearest whole number of the given unit,+-- not smaller than the given time.+--+-- @+-- ceilingUnit (sec 2.0) == sec 2+-- ceilingUnit (sec 2.1) == sec 3+-- ceilingUnit (sec 2.9) == sec 3+-- @+ceilingUnit :: forall (unit :: Rat) . Time unit -> Time unit+ceilingUnit = time . (% 1) . ceiling . unTime++-- | Converts the given time to a number with fixed-precision (in the given time unit).+--+-- @+-- timeToFixed (sec 1.234) == (1.2            :: Deci)+-- timeToFixed (sec 1.234) == (1.234          :: Milli)+-- timeToFixed (sec 1.234) == (1.234000000000 :: Pico)+-- @+timeToFixed+  :: forall precision unit+   . HasResolution precision+  => Time unit -> Fixed precision+timeToFixed = fromRational @(Fixed precision) . toRational . unTime++-- | Converts the given time to a 'NominalDiffTime'.+timeToNominalDiffTime :: KnownDivRat unit Second => Time unit -> NominalDiffTime+timeToNominalDiffTime =+  secondsToNominalDiffTime . timeToFixed . toUnit @Second++----------------------------------------------------------------------------+-- Bytes+----------------------------------------------------------------------------++stripOptional0x :: Text -> Text+stripOptional0x h = T.stripPrefix "0x" h ?: h++fromHex :: Text -> Maybe ByteString+fromHex = decodeHex . stripOptional0x++unsafeFromHex :: HasCallStack => Text -> ByteString+unsafeFromHex hex = fromHex hex+  ?: error ("Invalid hex: " <> show hex)++----------------------------------------------------------------------------+-- Loops+----------------------------------------------------------------------------++{- | Version of 'mapM' generalized with 'L.each'.++Example:++> (addr1, addr2, addr3) <- mapEach newAddress ("test1", "test2", "test3")++This is more type-safe than simple 'mapM' since lists do not remember+their length in types.+-}+mapEach+  :: (L.Each s t a b, Applicative m)+  => (a -> m b) -> s -> m t+mapEach = L.traverseOf L.each++-- | Version of 'mapEach' with arguments flipped.+forEach+  :: (L.Each s t a b, Applicative m)+  => s -> (a -> m b) -> m t+forEach = L.forOf L.each
+ test-common/Test/Util/Contracts.hs view
@@ -0,0 +1,107 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 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)
+ test/Main.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Cleveland.Ingredients (ourIngredients)+import Test.Cleveland.Tasty (clevelandMainWithIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= clevelandMainWithIngredients ourIngredients
+ test/TestSuite/Cleveland/AddressRevealing.hs view
@@ -0,0 +1,21 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.AddressRevealing+  ( test_AddressRevealing+  ) where++import Test.Tasty++import Test.Cleveland++test_AddressRevealing :: TestTree+test_AddressRevealing =+  testScenario "New address key is revealed" $ scenario do+    test <- newAddress auto+    test2 <- newFreshAddress auto++    transferMoney test 1000+    comment "new key address is revealed"+    withSender test $ transferMoney test2 1
+ test/TestSuite/Cleveland/Assertions.hs view
@@ -0,0 +1,111 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Assertions+  ( test_failure_fails+  , test_assert_succeeds+  , test_assert_fails+  , test_eq_succeeds+  , test_eq_fails+  , test_neq_succeeds+  , test_neq_fails+  , test_checkCompares_succeeds+  , test_checkCompares_fails+  , test_checkComparesWith_succeeds+  , test_checkComparesWith_fails+  ) where++import Fmt (pretty)+import Test.Tasty (TestTree)++import Test.Cleveland++import Morley.Util.Interpolate (i)+import TestSuite.Util (shouldFailWithMessage)++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++test_failure_fails :: TestTree+test_failure_fails =+  testScenario "`failure` fails unconditionally" $ scenario do+    failure @() "<error msg>"+      & shouldFailWithMessage "<error msg>"++test_assert_succeeds :: TestTree+test_assert_succeeds =+  testScenario "`assert` succeeds when condition is true" $ scenario $+    assert True "<error msg>"++test_assert_fails :: TestTree+test_assert_fails =+  testScenario "`assert` fails when condition is false" $ scenario do+    assert False "<error msg>"+      & shouldFailWithMessage "<error msg>"++test_eq_succeeds :: TestTree+test_eq_succeeds =+  testScenario "`@==` succeeds when the values are equal" $ scenario $+    True @== True++test_eq_fails :: TestTree+test_eq_fails =+  testScenario "`@==` fails when the values are not equal" $ scenario do+    (True @== False)+      & shouldFailWithMessage [i|+━━ Expected (rhs) ━━+False+━━ Got (lhs) ━━+True|]++test_neq_succeeds :: TestTree+test_neq_succeeds =+  testScenario "`@/=` succeeds when the values are not equal" $ scenario $+    True @/= False++test_neq_fails :: TestTree+test_neq_fails =+  testScenario "`@/=` fails when the values are equal" $ scenario do+    (True @/= True)+      & shouldFailWithMessage "The two values are equal:"++test_checkCompares_succeeds :: TestTree+test_checkCompares_succeeds =+  testScenario "`checkCompares` succeeds when the comparison succeeds" $ scenario $+    checkCompares @Int 2 elem [1, 2, 3]++test_checkCompares_fails :: TestTree+test_checkCompares_fails =+  testScenario "`checkCompares` fails when the comparison fails" $ scenario do+    checkCompares @Int 1 elem []+      & shouldFailWithMessage [i|+━━ lhs ━━+1+━━ rhs ━━+[]|]++test_checkComparesWith_succeeds :: TestTree+test_checkComparesWith_succeeds =+  testScenario "`checkComparesWith` succeeds when the comparison succeeds" $ scenario $+    checkComparesWith @Int pretty 2 elem pretty [1, 2, 3]++test_checkComparesWith_fails :: TestTree+test_checkComparesWith_fails =+  testScenario "`checkComparesWith` fails when the comparison fails and prints values" $ scenario do+    checkComparesWith @Int toCardinal 1 elem (show . fmap toOrdinal) [2, 3]+      & shouldFailWithMessage [i|+━━ lhs ━━+One+━━ rhs ━━+["Second","Third"]|]+  where+    toCardinal = \case+      1 -> "One"+      2 -> "Two"+      3 -> "Three"+      n -> show n+    toOrdinal = \case+      1 -> "First"+      2 -> "Second"+      3 -> "Third"+      n -> show @String n
+ test/TestSuite/Cleveland/BalanceCheck.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.BalanceCheck+  ( test_BalanceCheck+  , test_EmptyBalanceCheck+  ) where++import Test.Tasty++import Morley.Tezos.Address (Address)+import Test.Cleveland++test_BalanceCheck :: TestTree+test_BalanceCheck =+  testScenario "An address's balance can be checked" $ scenario do+    test :: Address <- newFreshAddress auto++    comment "balance is updated after transfer"+    transferMoney test 100+    getBalance test @@== 100++test_EmptyBalanceCheck :: TestTree+test_EmptyBalanceCheck =+  testScenario "An empty address' balance can be checked" $ scenario do+    test <- newFreshAddress auto+    dummy <- newFreshAddress auto++    -- Doing something in order not to get "validating empty scenario" error+    transferMoney dummy 1+    getBalance test @@== 0
+ test/TestSuite/Cleveland/BatchOperation.hs view
@@ -0,0 +1,49 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.BatchOperation+  ( test_SomeCases+  ) where++import Test.Tasty++import Lorentz.Value+import Test.Cleveland+import Test.Cleveland.Lorentz.Consumer++test_SomeCases :: [TestTree]+test_SomeCases =+  [ testScenario "Origination and transfer within a batch work" $ scenario do+      test1 <- newFreshAddress auto++      contract1 <- inBatch $ do+        contract1 <- originateSimple "c" ([] :: [()]) contractConsumer+        transferMoney test1 100+        return contract1++      getBalance test1 @@== 100++      transferMoney contract1 200+      getBalance contract1 @@== 200+++  , testScenario "Loops within batch work" $ scenario do+      test1 :: Address <- newFreshAddress auto+      test2 :: Address <- newFreshAddress auto++      inBatch $ do+        for_ [(test1, 100), (test2, 200)] $ uncurry transferMoney++      getBalance test1 @@== 100+      getBalance test2 @@== 200+++  , testScenario "Can return multiple values from a batch" $ scenario do+      (_contract1, _contract2) <- inBatch $ do+        contract1 <- originateSimple "c1" ([] :: [Integer]) contractConsumer+        contract2 <- originateSimple "c2" ([] :: [Integer]) contractConsumer+        return (contract1, contract2)++      return ()+  ]
+ test/TestSuite/Cleveland/BatchTransferCheck.hs view
@@ -0,0 +1,69 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE ApplicativeDo #-}++module TestSuite.Cleveland.BatchTransferCheck+  ( test_SimpleTransfer+  , test_BatchTransferLeapingCosts+  ) where++import Test.Tasty++import Lorentz ((#), (:->))+import qualified Lorentz as L+import Test.Cleveland++test_SimpleTransfer :: TestTree+test_SimpleTransfer =+  testScenario "Check the batch transaction correctness" $ scenario do+    test1 <- newFreshAddress auto+    test2 <- newFreshAddress auto++    comment "balance is updated after batch transfer"+    inBatch $ do+      for_ [100, 200] $ transferMoney test1+      transferMoney test2 300+      return ()++    getBalance test1 @@== 300+    getBalance test2 @@== 300++-- | Add given element on stack once on first invocation, and 10k times on+-- subsequent invocations.+leapingContract :: forall a. (L.NiceParameterFull a, L.NiceStorage [a], L.Dupable a) => L.Contract a [a] ()+leapingContract = L.defaultContract $+  L.unpair #+  L.duupX @2 # L.size # L.int # L.ifEq0 (L.push 1) (L.push 5000) #+  lIterate (L.dup @a # L.dip L.cons) #+  L.drop @a #+  L.nil # L.pair+  where+    lIterate :: s :-> s -> Natural : s :-> s+    lIterate f =+      decrease #+      L.loop (L.dip f # decrease) #+      L.drop @Natural++    decrease :: Natural : s :-> Bool : Natural : s+    decrease =+      L.push @Natural 1 # L.rsub # L.isNat #+      L.ifSome (L.push True) (L.push 999 # L.push False)++-- | Even in case when transactions in batch have very different costs,+-- and costs of subsequent transactions is affected by previous transactions,+-- everything works as expected.+test_BatchTransferLeapingCosts :: TestTree+test_BatchTransferLeapingCosts =+  testScenario "Check fees evaluation correctness for leaping transfer costs" $ scenario do+    contract <- originateSimple "contract" [] (leapingContract @L.MText)++    comment "Perform batch transfer, second transaction should have much \+            \higher cost with respect to the first one"+    inBatch $+      for_ ["a", "b"] $ call contract CallDefault++    comment "Sanity check on storage"+    getStorage contract @@==+      replicate 5000 "b" ++ one "a"
+ test/TestSuite/Cleveland/BlockIntervalGetter.hs view
@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.BlockIntervalGetter+  ( test_BlockIntervalGetter+  ) where++import Test.Tasty++import Test.Cleveland++test_BlockIntervalGetter :: TestTree+test_BlockIntervalGetter =+  testScenario "Approximate block interval can be obtained" $ scenario do+    comment "Getting approximate block interval"+    blockInterval <- getApproximateBlockInterval+    comment "Wait for obtained interval amount of time"+    advanceTime blockInterval
+ test/TestSuite/Cleveland/BytesSigning.hs view
@@ -0,0 +1,39 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.BytesSigning+  ( test_BytesSigning+  ) where++import Test.Tasty++import Lorentz ((#))+import qualified Lorentz as L+import Morley.Tezos.Crypto+import Test.Cleveland++checkSignatureContract :: L.Contract (PublicKey, (L.TSignature ByteString, ByteString)) () ()+checkSignatureContract = L.defaultContract $+  L.car #+  L.unpair # L.dip L.unpair #+  L.checkSignature # L.assert [L.mt|Invalid signature|] #+  L.unit # L.nil @L.Operation # L.pair++test_BytesSigning :: TestTree+test_BytesSigning =+  testScenario "Bytestrings can be signed" $ scenario do+    dummy <- newFreshAddress "user"+    signer <- newFreshAddress "signer"++    helper <- originateSimple "helper" () checkSignatureContract++    let bytes = "some bytestring"++    sig <- signBinary bytes signer+    signerPK <- getPublicKey signer+    dummyPK <- getPublicKey dummy++    expectFailedWith [L.mt|Invalid signature|] $+      call helper CallDefault (dummyPK, (sig, bytes))+    call helper CallDefault (signerPK, (sig, bytes))
+ test/TestSuite/Cleveland/CallStack.hs view
@@ -0,0 +1,815 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedLists #-}++module TestSuite.Cleveland.CallStack+  ( test_callStack+  , test_clarifyErrors+  , test_callStack_property+  ) where++import Lorentz hiding (assert, comment, not)++import Data.Char (isNumber, isSpace)+import qualified Data.List as List+import Fmt ((+|), (|+))+import Hedgehog (Property, property)+import Servant.Client+  (BaseUrl(BaseUrl), ClientEnv(baseUrl), ClientError(ConnectionError), Scheme(Http))+import System.FilePath ((</>))+import Test.Hspec.Expectations+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners (Result(resultDescription))+import Time (sec)+import qualified Unsafe++import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL, mkAlias)+import Morley.Client.TezosClient (tceEndpointUrlL)+import Morley.Michelson.Typed (convertContract, untypeValue)+import Morley.Tezos.Address (unsafeParseAddress)+import Morley.Util.Interpolate (lit)+import Test.Cleveland+import Test.Cleveland.Internal.Client (neMorleyClientEnvL)+import Test.Cleveland.Internal.Pure (TestError(CustomTestError))+import Test.Cleveland.Tasty++import TestSuite.Util+  (idContract, outcomeIsFailure, runPropertyViaTasty, runViaTastyOnEmulator, runViaTastyOnNetwork)++test_clarifyErrors :: [TestTree]+test_clarifyErrors =+  [ testFailureIncludesCallStack "Custom errors are prefixed with clarifyErrors"+          [lit|+                failure ("Some failure")+                ^^^^^^^^^^^^^^^^^^^^^^^^+                | For i=1: Some failure+          |]+          do+            for_ ([1..10] :: [Int]) \i ->+              clarifyErrors ("For i=" +| i |+ "") $+                failure ("Some failure")+  , testFailureIncludesCallStack "clarifyErrors properly formats multiline errors"+          [lit|+                failure ("Some failure\nSome text")+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+                | For i=1:+                |   Some failure+                |   Some text+          |]+          do+            for_ ([1..10] :: [Int]) \i ->+              clarifyErrors ("For i=" +| i |+ "") $+                failure ("Some failure\nSome text")+  , testFailureIncludesCallStack "clarifyErrors properly works for equality tests"+          [lit|+                i @== 1+                ^^^^^^^+                | For i=2:+                |   Failed comparison+                |   ━━ Expected (rhs) ━━+                |   1+                |   ━━ Got (lhs) ━━+                |   2+          |]+          do+            for_ ([1..10] :: [Int]) \i ->+              clarifyErrors ("For i=" +| i |+ "") $+                i @== 1+  , testFailureIncludesCallStack "clarifyErrors nests well"+          [lit|+                    i @== j+                    ^^^^^^^+                    | For i=1:+                    |   For j=2:+                    |     Failed comparison+                    |     ━━ Expected (rhs) ━━+                    |     2+                    |     ━━ Got (lhs) ━━+                    |     1+          |]+          do+            for_ ([1..10] :: [Int]) \i ->+              clarifyErrors ("For i=" +| i |+ "") $+                for_ ([1..10] :: [Int]) \j ->+                  clarifyErrors ("For j=" +| j |+ "") $+                    i @== j+  ]+++test_callStack :: TestTree+test_callStack =+  testGroup "Error messages include a helpful callstack" $+    [ testFailureIncludesCallStack "callstack points to runIO"+        [lit|+          runIO (throwM DummyException)+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          runIO (throwM DummyException)++    , testFailureIncludesCallStack "callstack points to resolveAddress"+        [lit|+          void $ resolveAddress invalidAlias+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by using an unknown alias+          void $ resolveAddress invalidAlias++    , testFailureIncludesCallStack "callstack points to newAddress"+        [lit|+            void $ newAddress "b"+                   ^^^^^^^^^^^^^^+        |]+        do+          addr <- newFreshAddress "a"+          -- force a failure by using an address without money as the donator+          withMoneybag addr $+            void $ newAddress "b"++    , testFailureIncludesCallStack "callstack points to signBytes"+        [lit|+          void $ signBytes "" invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ signBytes "" invalidAddr++    , testFailureIncludesCallStack "callstack points to signBinary"+        [lit|+          void $ signBinary @ByteString "" invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ signBinary @ByteString "" invalidAddr++    , testFailureIncludesCallStack "callstack points to originateUntyped"+        [lit|+          void $ originateUntyped UntypedOriginateData+            { uodName = ""+            , uodBalance = 0+            , uodStorage = untypeValue $ toVal @Natural 3+            , uodContract = convertContract $ toMichelsonContract @() @() idContract+            }+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by using a storage of the wrong type+          void $ originateUntyped UntypedOriginateData+            { uodName = ""+            , uodBalance = 0+            , uodStorage = untypeValue $ toVal @Natural 3+            , uodContract = convertContract $ toMichelsonContract @() @() idContract+            }++    , testFailureIncludesCallStack "callstack points to originateUntypedSimple"+        [lit|+          void $ originateUntypedSimple ""+            (untypeValue $ toVal @Natural 3)+            (convertContract $ toMichelsonContract @() @() idContract)+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by using a storage of the wrong type+          void $ originateUntypedSimple ""+            (untypeValue $ toVal @Natural 3)+            (convertContract $ toMichelsonContract @() @() idContract)++    , testFailureIncludesCallStack "callstack points to originate"+        [lit|+          void $ originate OriginateData+            { odName = ""+            , odBalance = maxBound+            , odStorage = ()+            , odContract = idContract @() @()+            }+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by transfering `maxBound` mutez+          void $ originate OriginateData+            { odName = ""+            , odBalance = maxBound+            , odStorage = ()+            , odContract = idContract @() @()+            }++    , testFailureIncludesCallStack "callstack points to transfer"+        [lit|+          transfer TransferData+            { tdTo = invalidAddr+            , tdAmount = 0+            , tdEntrypoint = DefEpName+            , tdParameter = ()+            }+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by transfering from an unknown alias+          transfer TransferData+            { tdTo = invalidAddr+            , tdAmount = 0+            , tdEntrypoint = DefEpName+            , tdParameter = ()+            }++    , testFailureIncludesCallStack "callstack points to transferMoney"+        [lit|+          transferMoney invalidAddr 1+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by transfering from an unknown address+          transferMoney invalidAddr 1+            & withSender invalidAddr++    , testFailureIncludesCallStack "callstack points to call"+        [lit|+          call invalidTAddr CallDefault ()+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by transfering to an unknown address+          call invalidTAddr CallDefault ()++    , testFailureIncludesCallStack "callstack points to inBatch for batched transfers"+        [lit|+          inBatch $ do+            call (TAddress @() invalidAddr) CallDefault ()+            call (TAddress @() invalidAddr) CallDefault ()+            return ()+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          -- force a failure by transfering to an unknown address+          inBatch $ do+            call (TAddress @() invalidAddr) CallDefault ()+            call (TAddress @() invalidAddr) CallDefault ()+            return ()++    , testFailureIncludesCallStack "callstack points to importUntypedContract"+        [lit|+          void $ importUntypedContract "<invalid file path>"+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ importUntypedContract "<invalid file path>"++    , testGroup "attempt"+      [ testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action"+          [lit|+                runIO $ throwM DummyException+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          |]+          do+            void $+              attempt @TransferFailure $+                runIO $ throwM DummyException+      ]++    , testGroup "catchTransferFailure" $+      [ testFailureIncludesCallStack "when action does not throw, callstack points to catchTransferFailure"+          [lit|+              catchTransferFailure+                pass+              ^^^^^^^^^^^^^^^^^^^^+          |]+          do+            void $+              catchTransferFailure+                pass+      , testGroup "when action throws an unexpected exception, callstack points to action" $+          let unexpectedExceptions =+                [ ( "DummyException"+                  , SomeException DummyException+                  )+                , ( "unexpected TestError constructor"+                  , SomeException $ CustomTestError "err"+                  )+                , ( "Servant ClientError"+                  , SomeException $ ConnectionError (SomeException DummyException)+                  )+                , ( "TezosClientError"+                  , SomeException EConnreset+                  )+                ]+          in  flip fmap unexpectedExceptions $ \(testName, SomeException ex) ->+                testFailureIncludesCallStack+                  testName+                  [lit|+                      runIO (throwM ex)+                      ^^^^^^^^^^^^^^^^^+                  |]+                  do+                    void $ catchTransferFailure $ do+                      pass+                      runIO (throwM ex)+                      pass+      ]++    , testFailureIncludesCallStack "when exception predicate fails, callstack points to checkTransferFailure"+        [lit|+          checkTransferFailure err $ failedWith (constant @Natural 2)+          ^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          addr <- originateSimple "" () contractFailWith1+          err <- catchTransferFailure $ call addr CallDefault ()+          checkTransferFailure err $ failedWith (constant @Natural 2)++    , testGroup "expectTransferFailure" $+      [ testFailureIncludesCallStack "when action does not throw, callstack points to expectTransferFailure"+          [lit|+              & expectTransferFailure emptyTransaction+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          |]+          do+            pass+              & expectTransferFailure emptyTransaction++      , testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action"+          [lit|+            runIO (throwM DummyException)+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          |]+          do+            runIO (throwM DummyException)+              & expectTransferFailure emptyTransaction++      , testFailureIncludesCallStack "when exception predicate fails, callstack points to expectTransferFailure"+          [lit|+              & expectTransferFailure (failedWith (constant @Natural 2))+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          |]+          do+            addr <- originateSimple "" () contractFailWith1+            call addr CallDefault ()+              & expectTransferFailure (failedWith (constant @Natural 2))+      ]++    , testFailureIncludesCallStack "callstack points to expectFailedWith"+        [lit|+          expectFailedWith @MText "" pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectFailedWith @MText "" pass++    , testFailureIncludesCallStack "callstack points to expectError"+        [lit|+          expectError @MText "" pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectError @MText "" pass++    , testFailureIncludesCallStack "callstack points to expectCustomError"+        [lit|+          expectCustomError #unitError () pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectCustomError #unitError () pass++    , testFailureIncludesCallStack "callstack points to expectCustomError_"+        [lit|+          expectCustomError_ #unitError pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectCustomError_ #unitError pass++    , testFailureIncludesCallStack "callstack points to expectCustomErrorNoArg"+        [lit|+          expectCustomErrorNoArg #noArgError pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectCustomErrorNoArg #noArgError pass++    , testFailureIncludesCallStack "callstack points to expectNumericError"+        [lit|+          expectNumericError @MText [] "" pass+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          expectNumericError @MText [] "" pass++    , testFailureIncludesCallStack "callstack points to getStorage"+        [lit|+          void $ getStorage @() invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ getStorage @() invalidAddr++    , testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator"+        [lit|+          void $ getFullStorage @() invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ getFullStorage @() invalidAddr++    , testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator"+        [lit|+          void $ getSomeStorage invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ getSomeStorage invalidAddr++    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to getBigMapValueMaybe"+          [lit|+            void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0+                   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          |]+          do+            void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0++    , testFailureIncludesCallStack "callstack points to getBigMapValue"+        [lit|+          void $ getBigMapValue @Integer @Integer 999999999999999999 0+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ getBigMapValue @Integer @Integer 999999999999999999 0++    , testFailureIncludesCallStack "callstack points to getPublicKey"+        [lit|+          void $ getPublicKey invalidAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          void $ getPublicKey invalidAddr++    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to getChainId on network"+          [lit|+            void getChainId+                 ^^^^^^^^^^+          |]+          do+            void getChainId++    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to advanceTime on network"+          [lit|+            advanceTime (sec 1)+            ^^^^^^^^^^^^^^^^^^^+          |]+          do+            advanceTime (sec 1)+    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to advanceLevel on network"+          [lit|+            advanceLevel 1+            ^^^^^^^^^^^^^^+          |]+          do+            advanceLevel 1+    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to getNow on network"+          [lit|+            void getNow+                 ^^^^^^+          |]+          do+            void getNow+    , sabotageNetworkEnv $+        testFailureIncludesCallStackOnNetwork "callstack points to getLevel on network"+          [lit|+            void getLevel+                 ^^^^^^^^+          |]+          do+            void getLevel+    , testFailureIncludesCallStackOnEmulator+        "when a branchout branch throws, the callstack points to the function inside the branch"+        [lit|+                  getStorage @() invalidAddr+                  ^^^^^^^^^^^^^^^^^^^^^^^^^^+                  | In 'a' branch:+                  | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC+        |]+        do+          branchout+            [ "a" ?-+                void $+                  getStorage @() invalidAddr+            ]+    , testFailureIncludesCallStackOnEmulator+        "when a branchout branch throws ANY exception, the exception raised is printed in a right way"+        [lit|+                runIO $ throwM DummyException+                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+                | In 'a' branch:+                | DummyException++        |]+        do+          branchout+            [ "a" ?-+                runIO $ throwM DummyException+            ]++    , testFailureIncludesCallStackOnEmulator+        "when offshoot throws, the callstack points to the function inside offshoot"+        [lit|+              getStorage @() invalidAddr+              ^^^^^^^^^^^^^^^^^^^^^^^^^^+              | In 'a' branch:+              | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC++        |]+        do+          offshoot "a" $+            void $+              getStorage @() invalidAddr++    , testFailureIncludesCallStack "callstack points to failure"+        [lit|+          failure "a"+          ^^^^^^^^^^^+        |]+        do+          failure "a"++    , testFailureIncludesCallStack "callstack points to assert"+        [lit|+          assert False "a"+          ^^^^^^^^^^^^^^^^+        |]+        do+          assert False "a"++    , testFailureIncludesCallStack "callstack points to @=="+        [lit|+          1 @== (2 :: Int)+          ^^^^^^^^^^^^^^^^+        |]+        do+          1 @== (2 :: Int)++    , testFailureIncludesCallStack "callstack points to @/="+        [lit|+          1 @/= (1 :: Int)+          ^^^^^^^^^^^^^^^^+        |]+        do+          1 @/= (1 :: Int)++    , testFailureIncludesCallStack "callstack points to @@=="+        [lit|+          pure 1 @@== (2 :: Int)+          ^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          pure 1 @@== (2 :: Int)++    , testFailureIncludesCallStack "callstack points to @@/="+        [lit|+          pure 1 @@/= (1 :: Int)+          ^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          pure 1 @@/= (1 :: Int)++    , testFailureIncludesCallStack "callstack points to checkCompares"+        [lit|+          checkCompares @Int 1 (==) 2+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          checkCompares @Int 1 (==) 2++    , testFailureIncludesCallStack "callstack points to checkComparesWith"+        [lit|+          checkComparesWith @Int show 1 (==) show 2+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        do+          checkComparesWith @Int show 1 (==) show 2++    , testFailureIncludesCallStack "callstack points to evalJust"+        [lit|+          Nothing & evalJust ""+                    ^^^^^^^^^^^+        |]+        do+          Nothing & evalJust ""++    , testFailureIncludesCallStack "callstack points to evalRight"+        [lit|+          Left @Integer 1 & evalRight \_ -> ""+                            ^^^^^^^^^^^^^^^^^^+        |]+        do+          Left @Integer 1 & evalRight \_ -> ""++    , testGroup "callstack points to a method at its top"+        [ testFailureIncludesCallStack' "callstack points to helper using @=="+            [lit|+              bulkCheck [0, 1] [0, 2]+              ^^^^^^^^^^^^^^^^^^^^^^^+            |]+            do+              let+                bulkCheck+                  :: (MonadCleveland caps m, HasCallStack)+                  => [Int] -> [Int] -> m ()+                bulkCheck = sequence_ ... zipWith (@==)++              bulkCheck [0, 1] [0, 2]+        ]+    ]++  where+    invalidAlias = mkAlias "UnknownAlias"+    invalidAddr = unsafeParseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC"+    invalidTAddr = TAddress @() invalidAddr++test_callStack_property :: TestTree+test_callStack_property =+  testGroup "Error messages of property tests include a helpful callstack" $+    [ testFailureIncludesCallStackProperty "callstack points to line which led scenario to error"+        [lit|+    f x y = x @== y+    ^^^^^^^^^^^^^^^+        |]+        dummyProp+    , testFailureIncludesCallStackProperty "callstack points to the line where the pure error was thrown"+        [lit|+  error "Pure error" @== (1 :: Int)+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        dummyPropWithPureError+    , testFailureIncludesCallStackProperty "callstack points to the line where the nested pure error was thrown"+        [lit|+  (10 - 11 :: Mutez) @== 0+  ^^^^^^^^^^^^^^^^^^^^^^^^+        |]+        dummyPropWithNestedPureError+    ]++testFailureIncludesCallStack+  :: HasCallStack+  => TestName+  -> String+  -> (forall caps m. MonadCleveland caps m => m ())+  -> TestTree+testFailureIncludesCallStack testName =+  testFailureIncludesCallStack'+    testName++-- | Check that exceptions thrown by the given function contain a callstack that points to that function.+--+-- The scenario is run on both the emulator and on a network.+testFailureIncludesCallStack'+  :: HasCallStack+  => TestName+  -> String+  -> (forall caps m. MonadCleveland caps m => m ())+  -> TestTree+testFailureIncludesCallStack' testName expectedErrorLines test =+  testGroup testName+    [ testFailureIncludesCallStackOnEmulator+        "On emulator"+        expectedErrorLines+        test+    , testFailureIncludesCallStackOnNetwork+        "On network"+        expectedErrorLines+        test+    ]++testFailureIncludesCallStackOnEmulator+  :: HasCallStack+  => TestName -> String -> (forall m. Monad m => EmulatedT m ()) -> TestTree+testFailureIncludesCallStackOnEmulator testName expectedErrorLines cleveland =+  runViaTastyOnEmulator testName mempty cleveland $ \tastyResult -> do+    outcomeIsFailure tastyResult+    checkErrorMessage (resultDescription tastyResult) expectedErrorLines++testFailureIncludesCallStackOnNetwork+  :: HasCallStack+  => TestName -> String -> (forall m. Monad m => ClevelandT m ()) -> TestTree+testFailureIncludesCallStackOnNetwork testName expectedErrorLines cleveland =+  runViaTastyOnNetwork testName mempty cleveland $ \tastyResult -> do+    outcomeIsFailure tastyResult+    checkErrorMessage (resultDescription tastyResult) expectedErrorLines++testFailureIncludesCallStackProperty+  :: HasCallStack+  => TestName -> String -> Property -> TestTree+testFailureIncludesCallStackProperty testName expectedErrorLines prop =+  runPropertyViaTasty testName mempty prop $ \tastyResult -> do+    outcomeIsFailure tastyResult+    checkErrorMessage (resultDescription tastyResult) expectedErrorLines++-- | If we can't force a function to fail on a network by, e.g.,+-- passing the wrong arguments or violating its pre-conditions,+-- we can use this function to mess with the 'NetworkEnv' config and force+-- the test to crash.+--+-- For example, 'newAddress' and 'getChainId' don't normally fail,+-- but if we mess with the config, they will.+sabotageNetworkEnv :: TestTree -> TestTree+sabotageNetworkEnv =+  modifyNetworkEnv f+  where+    faultyBaseUrl = BaseUrl Http "" 0 ""++    f :: NetworkEnv -> NetworkEnv+    f =+      (neMorleyClientEnvL.mceTezosClientL.tceEndpointUrlL .~ faultyBaseUrl) .+      (neMorleyClientEnvL.mceClientEnvL %~ \clientEnv -> clientEnv+        { baseUrl = faultyBaseUrl }+      )++-- | Checks that an error message includes a pretty-printed callstack,+-- and that it points to this file and contains the expected lines.+checkErrorMessage :: HasCallStack => String -> String -> Assertion+checkErrorMessage err (List.lines -> expectedLines) = do+  Unsafe.head (List.lines err) `shouldContain` ("test" </> "TestSuite" </> "Cleveland" </> "CallStack.hs")++  if expectedLines `List.isInfixOf` strippedErrorLines+    then pass+    else+      assertFailure $+        List.unlines $+          [ "Expected the error message to contain: " ]+          <> expectedLines+          <> [ "But it didn't. Actual error message was: "]+          <> strippedErrorLines++  where+    stripLineNumber line =+      line+      & List.dropWhile isSpace+      & List.dropWhile isNumber+      & List.dropWhile isSpace+      & List.dropWhile (== '┃')+      & List.drop 1++    -- Strip 1) the header, 2) the callstack entries, 3) the line numbers and 4) the vertical border+    -- from the error message, to make writing these tests easier.+    strippedErrorLines =+      err+      & List.lines+      & List.takeWhile (/= "CallStack (from HasCallStack):")+      & Unsafe.tail+      <&> stripLineNumber++----------------------------------------------------------------------------+-- Test data+----------------------------------------------------------------------------++type instance ErrorArg "unitError" = UnitErrorArg++instance CustomErrorHasDoc "unitError" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "Error for testing custom error handling in cleveland"++type instance ErrorArg "noArgError" = NoErrorArg++instance CustomErrorHasDoc "noArgError" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "Error for testing custom error handling in cleveland"++contractFailWith1 :: Contract () () ()+contractFailWith1 = defaultContract $+  push @Natural 1 # failWith++data DummyException = DummyException+  deriving stock (Eq, Show)++instance Exception DummyException where++----------------------------------------------------------------------------+-- Test scenarios+----------------------------------------------------------------------------++-- Note: it's important to define property test as a top-level function.+-- If we inline it, the test will always pass, because 'hedgehog' captures+-- the whole function body, which contains expectation, into the error message.+dummyProp :: Property+dummyProp = property $ testScenarioProps $ scenario  do+  let+    f x y = x @== y+    g y   = f 10 y++  g (20 :: Int)++dummyPropWithPureError :: Property+dummyPropWithPureError = property $ testScenarioProps $ scenario do+  error "Pure error" @== (1 :: Int)++dummyPropWithNestedPureError :: Property+dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do+  (10 - 11 :: Mutez) @== 0
+ test/TestSuite/Cleveland/ChainIdGet.hs view
@@ -0,0 +1,30 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.ChainIdGet+  ( test_ChainIdGet+  ) where++import Test.Tasty++import Lorentz ((#))+import qualified Lorentz as L+import Morley.Tezos.Core (ChainId, dummyChainId)+import Morley.Util.Named+import Test.Cleveland++type Storage = ("storage" :! ChainId)++checkChainIdContract :: L.Contract () Storage ()+checkChainIdContract = L.defaultContract $+  L.drop # L.chainId # L.toNamed #storage # L.nil @L.Operation # L.pair++test_ChainIdGet :: TestTree+test_ChainIdGet =+  testScenario "ChainId is retrievable" $ scenario do+    helperAddr <- originateSimple "helper" (#storage :! dummyChainId) checkChainIdContract++    chainId <- getChainId+    call helperAddr CallDefault ()+    getStorage helperAddr @@== #storage :! chainId
+ test/TestSuite/Cleveland/ContractAllocation.hs view
@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.ContractAllocation+  ( test_ContractAllocation+  ) where++import Test.Tasty++import Morley.Tezos.Address (Address)+import Morley.Util.Named+import Test.Cleveland++import TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator++test_ContractAllocation :: TestTree+test_ContractAllocation =+  testScenario "Contracts can be allocated and called" $ scenario do+    addresses :: [Address] <- replicateM 10 $ newFreshAddress auto+    let+      od = OriginateData+        { odName = "allocator"+        , odStorage = #storage :! (take 570 $ cycle addresses)+        , odBalance = 25+        , odContract = allocatorContract+        }++    allocatorAddr <- originate od++    call allocatorAddr CallDefault (take 25 $ cycle addresses)
+ test/TestSuite/Cleveland/DFS.hs view
@@ -0,0 +1,67 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.DFS+  ( test_CheckDFSExecutionOrder+  ) where++import Test.Tasty++import Lorentz.Address+import Lorentz.Entrypoints+import qualified Morley.Michelson.Typed as T+import Morley.Tezos.Core (Mutez, toMutez)+import Test.Cleveland+import Test.Util.Contracts (inContractsDir)++data TransferAllParameter+  = ReceiveXtz+  | GetBalance+  | Transfer Mutez+  deriving stock (Generic)+  deriving anyclass (T.IsoValue)++data TransferAllCallerParameter+  = Moneybag+  | CallTransfer Mutez+  | CallCPS (TAddress TransferAllParameter ())+  deriving stock (Generic)+  deriving anyclass (T.IsoValue)++instance ParameterHasEntrypoints TransferAllParameter where+  type ParameterEntrypointsDerivation TransferAllParameter = EpdPlain++instance ParameterHasEntrypoints TransferAllCallerParameter where+  type ParameterEntrypointsDerivation TransferAllCallerParameter = EpdPlain++test_CheckDFSExecutionOrder :: [TestTree]+test_CheckDFSExecutionOrder =+  -- The following scenario fails with insufficient balance error in+  -- case when operations are performed in the BFS order.+  -- Here is the operation queue:+  -- 1) callCPS+  -- 2) getBalance(1), getBalance(2)+  -- 3) getBalance(2), callTransfer(1)+  -- 4) callTransfer(1), callTransfer(2)+  -- 5) callTransfer(2), transfer(1)+  -- 6) transfer(1), transfer(2)+  -- 7) transfer(2), moneybag(1)+  -- 8) moneybag(1), moneybag(2)+  -- 9) moneybag(2) -- this operation will then fail due to insufficient transfer_all contract+  --    balance+  [ testScenario "Operations are performed in DFS order" $ scenario do+      transferAllAddr <-+        importContract (inContractsDir "transfer_all.tz")+        >>= originateSimple @TransferAllParameter "transfer_all" () . noViews+      transferAllCallerAddr <-+        importContract (inContractsDir "transfer_all_caller.tz")+        >>= originateSimple @TransferAllCallerParameter "transfer_all_caller" () . noViews+      transfer $ TransferData+        { tdTo = transferAllAddr+        , tdAmount = toMutez 100+        , tdEntrypoint = ep "receiveXtz"+        , tdParameter = ()+        } -- transferAllAddr (toMutez 100)+      call transferAllCallerAddr (Call @"CallCPS") (toTAddress transferAllAddr)+  ]
+ test/TestSuite/Cleveland/Emulated.hs view
@@ -0,0 +1,70 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Emulated+  ( test_Emulated+  ) where++import Test.Tasty++import Morley.Tezos.Address+import Test.Cleveland++import TestSuite.Util (shouldFailWithMessage)++test_Emulated :: [TestTree]+test_Emulated =+  [ testGroup "branchout"+    [ testScenarioOnEmulator "passes if all branches pass" $ scenarioEmulated $+        branchout+          [ "a" ?- pass+          , "b" ?- pass+          ]++    , testScenarioOnEmulator "fails if any branch fails" $ scenarioEmulated do+        addr <- newAddress auto+        let branchA = "a" ?- transferMoney addr 0+        let branchB = "b" ?- pass+        branchout [branchA, branchB] & expectTransferFailure emptyTransaction+        branchout [branchB, branchA] & expectTransferFailure emptyTransaction++    , testScenarioOnEmulator "a branch's effects do not leak into another branch" $ scenarioEmulated do+        test <- newAddress auto+        initialBalance <- getBalance test+        branchout+          [ "a" ?- do+              transferMoney test 2+              getBalance test @@== initialBalance + 2+          , "b" ?- do+              transferMoney test 3+              getBalance test @@== initialBalance + 3+          ]++    , testScenarioOnEmulator "branchout's effects are discarded" $ scenarioEmulated do+        test <- newAddress auto+        initialBalance <- getBalance test+        branchout+          [ "a" ?- transferMoney test 3 ]+        getBalance test @@== initialBalance++    , testScenarioOnEmulator "adds branch name to error" $ scenarioEmulated do+        branchout+          [ "<branch name>" ?- void $+              signBytes "" (unsafeParseAddress "tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM")+          ]+          & shouldFailWithMessage "<branch name>"+    ]+  , testGroup "offshoot"+    [ testScenarioOnEmulator "fails if inner scenario fails" $ scenarioEmulated do+        addr <- newAddress auto+        offshoot "a" (transferMoney addr 0)+          & expectTransferFailure emptyTransaction++    , testScenarioOnEmulator "offshoot's effects are discarded" $ scenarioEmulated do+        test <- newAddress auto+        initialBalance <- getBalance test+        offshoot "a" $ transferMoney test 1+        getBalance test @@== initialBalance+    ]+  ]
+ test/TestSuite/Cleveland/Entrypoints.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Entrypoints+  ( test_duplicateEntrypoints+  ) where++import Test.Tasty.Runners++import Morley.Michelson.Untyped++import Test.Cleveland.Michelson.Entrypoints+import TestSuite.Cleveland.Lorentz.Entrypoints (expectFailure)++test_duplicateEntrypoints :: TestTree+test_duplicateEntrypoints = testContractMatchesEntrypoints "Ill-typed contract fails the test"+  illTypedContract mempty+  & expectFailure "Duplicated entrypoint names: 'do1'"+  where+    n = unsafeMkAnnotation ""+    do1 = unsafeMkAnnotation "do1"+    illTypedContract =+      Contract+        { contractParameter = ParameterType (+            Ty (TOr do1 do1 (Ty TInt n)+                 (Ty (TPair n n n n (Ty TInt n) (Ty TInt n)) n)) n) n+        , contractStorage = Ty TUnit n+        , contractCode = []+        , entriesOrder = PSC+        , contractViews = []+        }
+ test/TestSuite/Cleveland/ExpectFailure.hs view
@@ -0,0 +1,404 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module TestSuite.Cleveland.ExpectFailure+  ( test_CatchExceptions+  , test_FailsIfTheGivenActionDoesNotThrow+  , test_BranchErrorHandleInRightWay+  , hprop_BooleanOperators_Flatten_TransferFailurePredicates+  , test_TransferFailure_predicates+  ) where++import Lorentz as L hiding (comment)++import Data.Either.Validation (Validation(Success))+import Fmt (Builder, jsonListF', pretty, unlinesF)+import Hedgehog hiding (failure)+import qualified Hedgehog.Gen as Gen+import Test.Tasty++import Morley.Micheline (toExpression)+import Morley.Michelson.Runtime.GState (genesisAddress1)+import Morley.Tezos.Address (unsafeParseAddress)+import Morley.Tezos.Core (parseChainId)+import Morley.Util.Interpolate (i)+import Test.Cleveland+import Test.Cleveland.Internal.Abstract+  (ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..), TransferFailure(..),+  TransferFailureReason(..))+import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..))+import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Pure (emptyScenarioBranch)+import Test.Cleveland.Util (failedTest, unsafeFromHex)+import TestSuite.Util (shouldFailWithMessage)++test_CatchExceptions :: TestTree+test_CatchExceptions =+  testScenario "catches exceptions" $ scenario do+    validAddr <- newAddress auto+    contractAddr <- originate OriginateData+      { odName = "test catchTransferFailure"+      , odStorage = ()+      , odBalance = 1+      , odContract = defaultContract testContractCode+      }++    let (testContractWithNumericErrors, errorTagMap) = useNumericErrors testContractCode+    contractNumericAddr <- originate OriginateData+      { odName = "test catchTransferFailure numeric errors"+      , odStorage = ()+      , odBalance = 1+      , odContract = defaultContract testContractWithNumericErrors+      }++    attempt (call contractAddr (Call @"TriggerFailWith") ()) >>= \case+      Left err -> checkTransferFailure err $ failedWith (constant [mt|oops|])+      Right _ -> failure "Expected contract to fail"++    catchTransferFailure $+      call contractAddr (Call @"TriggerFailWith") ()++    expectTransferFailure (failedWith (constant [mt|oops|])) $+      call contractAddr (Call @"TriggerFailWith") ()++    expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $+      call contractAddr (Call @"TriggerFailWith") ()++    expectFailedWith [mt|oops|] $+      call contractAddr (Call @"TriggerFailWith") ()++    expectError (VoidResult False) $+      call contractAddr (Call @"VoidEP") (mkVoid True)++    expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural)))  $+      call contractAddr (Call @"TriggerFailWithRightCombedPair") ()++    -- Check that string and bytes forms of 'chain_id' are equal if they are+    -- used as error argument.+    let c = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"+    expectTransferFailure+      (failedWith (constant @ChainId c)) $+        call contractAddr (Call @"TriggerFailWithChainIdStr") ()++    expectTransferFailure+      (failedWith (constant @ChainId c)) $+        call contractAddr (Call @"TriggerFailWithChainIdBytes") ()++    expectCustomError #customError 1 $+      call contractAddr (Call @"TriggerFailWithCustomError") ()++    expectCustomError_ #customErrorUnit1 $+      call contractAddr (Call @"TriggerFailWithCustomErrorUnit1") ()++    expectCustomError_ #customErrorUnit2 $+      call contractAddr (Call @"TriggerFailWithCustomErrorUnit2") ()++    expectCustomErrorNoArg #customErrorNoArg $+      call contractAddr (Call @"TriggerFailWithCustomErrorNoArg") ()++    expectNumericError errorTagMap (VoidResult False) $+      call contractNumericAddr (Call @"VoidEP") (mkVoid True)++    expectTransferFailure shiftOverflow $+      call contractAddr (Call @"TriggerShiftOverflow") ()++    expectTransferFailure gasExhaustion $+      call contractAddr (Call @"TriggerGasExhaustion") ()++    expectTransferFailure emptyTransaction $+      transferMoney validAddr 0++    expectTransferFailure badParameter $+      transfer TransferData+        { tdTo = contractAddr+        , tdAmount = 0+        , tdEntrypoint = ep "expectAddress"+        , tdParameter = [mt|aa|]+        }++    expectTransferFailure badParameter $+      transfer TransferData+        { tdTo = contractAddr+        , tdAmount = 0+        , tdEntrypoint = ep "expectAddress"+        , tdParameter = (1 :: Natural)+        }++    -- check that an action throws one of many errors.+    let expectedErrs =+          failedWith (constant @Integer 1) ||+          failedWith (constant @MText "oops") ||+          failedWith (customError #customError 1)++    call contractAddr (Call @"TriggerFailWithCustomError") () &+      expectTransferFailure expectedErrs++test_FailsIfTheGivenActionDoesNotThrow :: TestTree+test_FailsIfTheGivenActionDoesNotThrow =+  testScenario "catchTransferFailure fails when the given action does not throw" $ scenario $+    catchTransferFailure pass+      & shouldFailWithMessage (pretty UnexpectedSuccess)++test_BranchErrorHandleInRightWay :: TestTree+test_BranchErrorHandleInRightWay =+  testScenario "catchTransferFailure and attempt unwrap exceptions with extra info" $ scenario do+    let action =+          runIO . throwM $+              WithCallStack callStack $ SomeException $+                FailedInBranch emptyScenarioBranch $ SomeException $+                  WithCallStack callStack $ SomeException $+                    FailedInBranch emptyScenarioBranch $ SomeException $+                      TransferFailure (unsafeParseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") BadParameter++    res <- attempt @TransferFailure action++    case res of+      Left err -> checkTransferFailure err badParameter+      Right _ -> failure $ "Expected 'attempt' to return a 'bad parameter' exception, but it succeeded."++    action & expectTransferFailure badParameter++data Parameter+  = ExpectAddress Address+    -- ^ Entrypoint that expects an Address as an argument+  | TriggerFailWith+    -- ^ Entrypoint that always fails with the string "oops"+  | TriggerShiftOverflow+    -- ^ Entrypoint that always fails with a shift overflow error.+  | TriggerGasExhaustion+    -- ^ Entrypoint that tried to fall into an infinite loop.+  | VoidEP (Void_ Bool Bool)+    -- ^ A Void entrypoint+  | TriggerFailWithCustomError+    -- ^ Entrypoint that always fails with a custom Lorentz error+  | TriggerFailWithCustomErrorUnit1+    -- ^ Entrypoint that always fails with a custom Lorentz error with a Unit param+  | TriggerFailWithCustomErrorUnit2+    -- ^ Entrypoint that always fails with a custom Lorentz error with a Unit param+  | TriggerFailWithCustomErrorNoArg+    -- ^ Entrypoint that always fails with a custom Lorentz error with no parameter+  | TriggerFailWithRightCombedPair+    -- ^ Entrypoint that always fails with the (1, (2, 3)) pair+  | TriggerFailWithChainIdStr+    -- ^ Entrypoint that always fails with the chain_id "NetXUdfLh6Gm88t"+  | TriggerFailWithChainIdBytes+    -- ^ Entrypoint that always fails with the chain_id "NetXUdfLh6Gm88t"+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntrypoints Parameter where+  type ParameterEntrypointsDerivation Parameter = EpdPlain++-- | A contract that triggers a variety of error scenarios+-- depending on the argument it's given.+testContractCode :: ContractCode Parameter ()+testContractCode =+  car #+  entryCaseSimple @Parameter+    ( #cExpectAddress /-> L.drop # push () # nil # pair+    , #cTriggerFailWith /-> push ("oops" :: MText) # failWith+    , #cTriggerShiftOverflow /->+        push @Natural 257 #+        push @Natural 1 #+        lsl #+        L.drop # push () # nil @Operation # pair+    , #cTriggerGasExhaustion /-> push True # loop (push True) # failUsing [mt|mem|]+    , #cVoidEP /-> void_ L.not+    , #cTriggerFailWithCustomError /-> push @Natural 1 # failCustom #customError+    , #cTriggerFailWithCustomErrorUnit1 /-> failCustom_ #customErrorUnit1+    , #cTriggerFailWithCustomErrorUnit2 /-> failCustom_ #customErrorUnit2+    , #cTriggerFailWithCustomErrorNoArg /-> failCustomNoArg #customErrorNoArg+    , #cTriggerFailWithRightCombedPair /-> push @(Natural, (Natural, Natural)) (1, (2, 3)) # failWith+    , #cTriggerFailWithChainIdStr /-> push @MText "NetXUdfLh6Gm88t" # failWith+    , #cTriggerFailWithChainIdBytes /-> push @ByteString (unsafeFromHex "458aa837") # failWith+    )++type instance ErrorArg "customError" = Natural+instance CustomErrorHasDoc "customError" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "N/A"++type instance ErrorArg "customErrorUnit1" = ()+instance CustomErrorHasDoc "customErrorUnit1" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "N/A"++type instance ErrorArg "customErrorUnit2" = L.UnitErrorArg+instance CustomErrorHasDoc "customErrorUnit2" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "N/A"++type instance ErrorArg "customErrorNoArg" = L.NoErrorArg+instance CustomErrorHasDoc "customErrorNoArg" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "N/A"++hprop_BooleanOperators_Flatten_TransferFailurePredicates :: Property+hprop_BooleanOperators_Flatten_TransferFailurePredicates = do+  property $ do+    predicate <- forAllWith (pretty . showPredicate) genTransferFailurePredicate++    case predicate of+      TransferFailurePredicate _ -> pass+      AndPredicate ps -> forM_ ps (isFlattened predicate)+      OrPredicate ps -> forM_ ps (isFlattened predicate)++  where+    -- | Check that, in a tree of predicates:+    --+    -- * an "and" node is never followed by another "and" node.+    -- * an "or" node is never followed by another "or" node.+    isFlattened :: TransferFailurePredicate -> TransferFailurePredicate -> PropertyT IO ()+    isFlattened parentPredicate predicate =+      case predicate of+        TransferFailurePredicate _ -> pass+        AndPredicate ps -> do+          case parentPredicate of+            AndPredicate _ -> failedTest "Found 2 adjacent 'and' nodes"+            _ -> pass++          forM_ ps (isFlattened predicate)+        OrPredicate ps -> do+          case parentPredicate of+            OrPredicate _ -> failedTest "Found 2 adjacent 'or' nodes"+            _ -> pass++          forM_ ps (isFlattened predicate)++    showPredicate :: TransferFailurePredicate -> Builder+    showPredicate = \case+      TransferFailurePredicate _ -> "TransferFailurePredicate \\_ -> Success ()"+      AndPredicate ps ->+        pretty $ unlinesF+          [ "AndPredicate"+          , jsonListF' showPredicate ps+          ]+      OrPredicate ps ->+        pretty $ unlinesF+          [ "OrPredicate"+          , jsonListF' showPredicate ps+          ]++    genTransferFailurePredicate :: Gen TransferFailurePredicate+    genTransferFailurePredicate =+      Gen.recursive Gen.choice+        [ pure $ TransferFailurePredicate \_ -> Success ()+        ]+        [ Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (&&)+        , Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (||)+        ]++testFailWith+  :: ConstantScope t => ((Value t -> ExpressionOrTypedValue) -> TestTree)+  -> [TestTree]+testFailWith f =+  [ testGroup "with EOTVExpression" $ [f (EOTVExpression . toExpression)]+  , testGroup "with EOTVTypedValue" $ [f EOTVTypedValue] ]++test_TransferFailure_predicates :: [TestTree]+test_TransferFailure_predicates = concatMap testFailWith $+  [ impl_test_AndPredicate_succeeds_if_all_conditions_hold+  , impl_test_OrPredicate_succeeds_if_any_condition_holds+  , impl_test_AndPredicate_fails_if_any_condition_fails+  , impl_test_OrPredicate_fails_if_all_conditions_fail+  , impl_test_checkTransferFailure_shows_only_failing_predicates ]++impl_test_AndPredicate_succeeds_if_all_conditions_hold+  , impl_test_OrPredicate_succeeds_if_any_condition_holds+  , impl_test_AndPredicate_fails_if_any_condition_fails+  , impl_test_OrPredicate_fails_if_all_conditions_fail+  , impl_test_checkTransferFailure_shows_only_failing_predicates+  :: (Value (ToT Integer) -> ExpressionOrTypedValue) -> TestTree++impl_test_AndPredicate_succeeds_if_all_conditions_hold conv =+  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do+    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    checkTransferFailure err $ failedWith (constant @Integer 1) && addressIs genesisAddress1++impl_test_OrPredicate_succeeds_if_any_condition_holds conv =+  testScenario "AndPredicate succeeds if any condition holds" $ scenario do+    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    checkTransferFailure err $+      failedWith (constant @Integer 1) ||+      failedWith (constant @Integer 2) ||+      failedWith (constant @Integer 3)++impl_test_AndPredicate_fails_if_any_condition_fails conv =+  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do+    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing++    checkTransferFailure err+      ( failedWith (constant @Integer 1) &&+        failedWith (constant @Integer 2) &&+        failedWith (constant @Integer 3)+      )+      & shouldFailWithMessage [i|+Expected transfer to fail with an error such that:++  (+    Contract failed with: 2+    AND+    Contract failed with: 3+  )++But these conditions were not met.+Actual transfer error:+  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]++impl_test_OrPredicate_fails_if_all_conditions_fail conv =+  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do+    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing++    checkTransferFailure err+      ( failedWith (constant @Integer 2) ||+        failedWith (constant @Integer 3) ||+        failedWith (constant @Integer 4)+      )+      & shouldFailWithMessage [i|+Expected transfer to fail with an error such that:++  (+    Contract failed with: 2+    OR+    Contract failed with: 3+    OR+    Contract failed with: 4+  )++But these conditions were not met.+Actual transfer error:+  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]++impl_test_checkTransferFailure_shows_only_failing_predicates conv =+  testScenario "checkTransferFailure shows only failing predicates" $ scenario do+    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing++    checkTransferFailure err+      ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) &&+        (failedWith (constant @Integer 3) && failedWith (constant @Integer 4)) &&+        (failedWith (constant @Integer 1) || failedWith (constant @Integer 6)) &&+        (failedWith (constant @Integer 7) || failedWith (constant @Integer 8))+      )+      & shouldFailWithMessage [i|+Expected transfer to fail with an error such that:++  (+    Contract failed with: 2+    AND+    Contract failed with: 3+    AND+    Contract failed with: 4+    AND+    (+      Contract failed with: 7+      OR+      Contract failed with: 8+    )+  )++But these conditions were not met.+Actual transfer error:+  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]
+ test/TestSuite/Cleveland/FailureLogs.hs view
@@ -0,0 +1,45 @@+-- SPDX-FileCopyrightText: 2022 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.FailureLogs+  ( test_FailureLogs+  ) where++import qualified Lorentz as L hiding (comment)++import Test.Tasty (TestTree)++import Morley.Michelson.Interpret (unMorleyLogs)+import Test.Cleveland++test_FailureLogs :: TestTree+test_FailureLogs =+  testScenarioOnEmulator "Can get logs even on scenario failure" $ scenarioEmulated do+    contractAddr <- originateSimple "test catchTransferFailure" () testContract++    (logs1, result1) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do+      call contractAddr L.CallDefault 0+      call contractAddr L.CallDefault 1+      failure "some failure"+    assert (isLeft result1) "result1 should be Left"+    unMorleyLogs logs1 @== ["One", "Two", "Three", "Four", "One", "Two"]++    (logs2, result2) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do+      call contractAddr L.CallDefault 0+      failure "some failure"+      call contractAddr L.CallDefault 1+    assert (isLeft result2) "result2 should be Left"+    unMorleyLogs logs2 @== ["One", "Two", "Three", "Four"]++testContract :: L.Contract Integer () ()+testContract =  L.defaultContract @Integer $+      L.car+  L.# L.printComment "One"+  L.# L.printComment "Two"+  L.# L.ifEq0 L.nop (L.push () L.# L.failWith)+  L.# L.printComment "Three"+  L.# L.printComment "Four"+  L.# L.unit+  L.# L.nil+  L.# L.pair
+ test/TestSuite/Cleveland/Import.hs view
@@ -0,0 +1,88 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on importing functionality.+module TestSuite.Cleveland.Import+  ( test_Import+  , test_Embed+  , test_ImportInt+  , test_EmbedInt+  , test_ImportAddress+  , test_EmbedAddress+  , test_ImportMutez+  , test_EmbedMutez+  ) where++import Test.Tasty++import Lorentz.Value (Address, Mutez)+import Morley.Tezos.Address (ta)+import Test.Cleveland+import Test.Cleveland.Lorentz (embedContract, embedValue, importValue)++test_Import :: [TestTree]+test_Import =+  [ testScenario "Can embed a contract" $ scenario do+      contract <- originateSimple "basic1" []+        $$(embedContract @() @[Integer] @() "../../contracts/basic1.tz")++      call contract CallDefault ()+  ]++test_Embed :: [TestTree]+test_Embed =+  [ testScenario "Can embed a contract" $ scenario do+      contractCode <- importContract @() @[Integer] @() "../../contracts/basic1.tz"+      contract <- originateSimple "basic1" [] contractCode++      call contract CallDefault ()+  ]++test_ImportInt :: [TestTree]+test_ImportInt =+  [ testScenarioOnEmulator "Can import an int value" $ scenario do+      value <- runIO $ importValue @Integer "./test/fixtures/intValue.txt"++      value @== 42+  ]++test_EmbedInt :: [TestTree]+test_EmbedInt =+  [ testScenarioOnEmulator "Can embed an int value" $ scenario do+      let value = $$(embedValue @Integer "./test/fixtures/intValue.txt")++      value @== 42+  ]++test_ImportAddress :: [TestTree]+test_ImportAddress =+  [ testScenarioOnEmulator "Can import an address value" $ scenario do+      value <- runIO $ importValue @Address "./test/fixtures/addrValue.txt"++      value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]+  ]++test_EmbedAddress :: [TestTree]+test_EmbedAddress =+  [ testScenarioOnEmulator "Can embed an address value" $ scenario do+      let value = $$(embedValue @Address "./test/fixtures/addrValue.txt")++      value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]+  ]++test_ImportMutez :: [TestTree]+test_ImportMutez =+  [ testScenarioOnEmulator "Can import a mutez value" $ scenario do+      value <- runIO $ importValue @Mutez "./test/fixtures/intValue.txt"++      value @== 42+  ]++test_EmbedMutez :: [TestTree]+test_EmbedMutez =+  [ testScenarioOnEmulator "Can embed a mutez value" $ scenario do+      let value = $$(embedValue @Mutez "./test/fixtures/intValue.txt")++      value @== 42+  ]
+ test/TestSuite/Cleveland/InitialState.hs view
@@ -0,0 +1,43 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for the initial state configuration of emulated scenarios++module TestSuite.Cleveland.InitialState+  ( test_init+  ) where++import Hedgehog (property, withTests)+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Morley.Tezos.Core (Timestamp(..))+import Test.Cleveland++test_init :: IO [TestTree]+test_init = do+  let expectedNow = Timestamp 1000_000+  let expectedLevel = 2255+  pure+    [ testProperty "Sets initial configuration and check it works as expected in emulator" $+        withTests 10 $ property $ testScenarioProps $+          withInitialLevel expectedLevel $+          withInitialNow expectedNow $ scenario $ do+            (getNow @@== expectedNow)+            (getLevel @@== expectedLevel)++    , testScenarioOnEmulator "Sets initial configuration and check the envirionment is as expected in emulated unit tests"+        $ withInitialNow expectedNow+        $ withInitialLevel expectedLevel+        $ scenario $ do+            getLevel @@== expectedLevel+            getNow @@== expectedNow++    , testScenarioOnEmulator "Sets initial configuration and check the envirionment is as expected in emulated unit tests"+        $ withInitialNow expectedNow+        $ withInitialLevel expectedLevel+        $ scenarioEmulated $ do+            getLevel @@== expectedLevel+            getNow @@== expectedNow+    ]
+ test/TestSuite/Cleveland/Level.hs view
@@ -0,0 +1,99 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Level+  ( test_CompareLevels+  , test_Level+  ) where++import Test.Tasty+import Test.Tasty.HUnit++import Morley.Michelson.Runtime.Dummy (dummyLevel)+import Test.Cleveland+import Test.Cleveland.Internal.Abstract (EmulatedCaps)++-- | Smart comparison for levels.+--+-- In a run against real chain, level can manage to advance during the test+-- execution, so we have to allow inaccuracy in return values of @getLevel@.+compareLevels+  :: RunMode caps+  -> Natural  -- ^ Level we got+  -> Natural  -- ^ Expected level+  -> Bool+compareLevels = \case+  EmulationMode -> (==)+  NetworkMode -> \got expected -> and [got >= expected, got <= expected + 1]++test_CompareLevels :: TestTree+test_CompareLevels =+  testCase "compareLevels allows the desired numbers" do+    compareLevels (EmulationMode @(EmulatedCaps PureM)) 5 5 @?= True+    compareLevels (EmulationMode @(EmulatedCaps PureM)) 6 5 @?= False++    compareLevels NetworkMode 5 5 @?= True+    compareLevels NetworkMode 6 5 @?= True++test_Level :: TestTree+test_Level =+  testGroup "functions for level advancing" $+    [ testGroup "advanceLevel" $+      [ testGroup "advances levels by the exact number" $+          testDeltas <&> \delta ->+            testScenario (show delta) $ scenario do+              l0 <- getLevel+              advanceLevel delta+              l1 <- getLevel++              runMode <- getRunMode+              assert (compareLevels runMode l1 (l0 + delta)) $+                mconcat+                  [ "Expected exactly "+                  , show delta+                  , " levels to be skipped, but "+                  , show (l1 - l0)+                  , " were actually skipped."+                  ]+      ]+    , testGroup "advanceToLevel" $+        [ testGroup "advances levels to the exact level" $+            testDeltas <&> \delta ->+              testScenario (show delta) $ scenario do+                l0 <- getLevel+                advanceToLevel (l0 + delta)+                l1 <- getLevel++                runMode <- getRunMode+                assert (compareLevels runMode l1 (l0 + delta)) $+                  mconcat+                    [ "Expected to be at level "+                    , show (l0 + delta)+                    , " but was at "+                    , show l1+                    , "."+                    ]+        , testScenario "is no-op if target level is lower than current level"  $ scenario do+              l0 <- getLevel+              advanceToLevel (fromInteger $ (fromIntegral @_ @Integer l0) - 4)+              l1 <- getLevel++              runMode <- getRunMode+              assert (compareLevels runMode l1 l0) $+                mconcat+                  [ "Expected to be at level "+                  , show l0+                  , " but was at "+                  , show l1+                  , "."+                  ]+        ]+    , testScenarioOnEmulator "initial level is 'dummyLevel' in the emulator" $ scenarioEmulated do+        l0 <- getLevel+        l0 @== dummyLevel+    ]+  where+    testDeltas :: [Natural]+    testDeltas =+      [0, 1, 2, 3, 4]
+ test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs view
@@ -0,0 +1,31 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator+  ( allocatorContract+  ) where++import Lorentz as L++import Test.Cleveland.Instances ()++allocatorContract :: Contract [Address] Storage ()+allocatorContract = defaultContract allocatorContractLorentz++type Storage = ("storage" :! [Address])++allocatorContractLorentz :: ContractCode [Address] Storage+allocatorContractLorentz =+  unpair #+  dip (nil @Operation) #+  iter (+    unsafeContractCalling @() DefEpName #+    whenSome+      (push 1 # unit # transferTokens # cons)+    ) #+  unit # push 0 # none @KeyHash #+  createContract @() @() (defaultContract failWith) #+  dip L.drop #+  cons #+  pair
+ test/TestSuite/Cleveland/Lorentz/Entrypoints.hs view
@@ -0,0 +1,154 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- To avoid explicitly depending on @containers@+{-# LANGUAGE OverloadedLists #-}++module TestSuite.Cleveland.Lorentz.Entrypoints+  ( test_ContractCoversEntrypoints+  , test_ContractMatchEntrypoints+  , test_ContractMatchEntrypointsT+  , test_ContractCoverEntrypointsT+  , expectFailure+  ) where++import qualified Lorentz as L++import Data.List (isInfixOf)+import Test.Tasty (testGroup)+import Test.Tasty.HUnit+import Test.Tasty.Providers (IsTest, run)+import Test.Tasty.Runners++import Lorentz.Annotation+import Lorentz.Constraints+import Lorentz.Entrypoints+import Lorentz.Run+import Lorentz.Value+import qualified Morley.Michelson.Untyped as U++import Test.Cleveland.Lorentz.Entrypoints++data MyEntrypoints1+  = Do1 Integer+  | Do2 (Integer, Integer)+  | Do3 MyEntrypoints2+  | Do4 MyParams+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyEntrypoints2+  = Do10+  | Do11 Natural+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++data MyParams = MyParams+  { param1 :: ()+  , param2 :: ByteString+  }+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++instance ParameterHasEntrypoints MyEntrypoints1 where+  type ParameterEntrypointsDerivation MyEntrypoints1 = EpdRecursive++instance ParameterHasEntrypoints MyEntrypoints2 where+  type ParameterEntrypointsDerivation MyEntrypoints2 = EpdPlain++dummyContract :: NiceParameterFull param => Contract param () ()+dummyContract = L.defaultContract $+  L.drop L.# L.unit L.# L.nil L.# L.pair++epSpecPartial :: Map EpName U.Ty+epSpecPartial =+  [ ( U.UnsafeEpName "do1", U.Ty (U.TInt) def )+  , ( U.UnsafeEpName "do2"+    , U.Ty (U.TPair def def def def (U.Ty U.TInt def) (U.Ty U.TInt def)) def )+  , ( U.UnsafeEpName "do10", U.Ty (U.TUnit) def )+  , ( U.UnsafeEpName "do11", U.Ty (U.TNat) def )+  ]++epSpecFull :: Map EpName U.Ty+epSpecFull = epSpecPartial <>+  [ ( U.UnsafeEpName "do4"+    , U.Ty (+        U.TPair (U.unsafeMkAnnotation "param1")+                (U.unsafeMkAnnotation "param2")+                def+                def+                (U.Ty U.TUnit def)+                (U.Ty U.TBytes def)+        ) def )+  ]++extractTests :: TestTree -> (forall t. IsTest t => String -> t -> TestTree) -> TestTree+extractTests tree f = case tree of+  SingleTest name t -> f name t+  TestGroup name ts -> testGroup name $ map (`extractTests` f) ts+  _ -> error "unsupported"++expectFailure :: String -> TestTree -> TestTree+expectFailure str tree = AskOptions $ \opts ->+  extractTests tree $ \name test -> testCase name do+    result <- run opts test (const $ pure ())+    case result of+      Result{..} -> do+        assertBool "Result is failure" $ case resultOutcome of+          Failure TestFailed -> True+          _ -> False+        if str `isInfixOf` resultDescription+        then pass+        else assertFailure $ "Expected '" <> resultDescription <> "' to contain '" <> str <> "'"++test_ContractCoversEntrypoints :: [TestTree]+test_ContractCoversEntrypoints =+  [ testContractCoversEntrypoints+      "testContractCoversEntrypoints works as expected"+        (dummyContract @MyEntrypoints1) epSpecPartial+  , testContractCoversEntrypoints+      "testContractCoversEntrypoints fails on wrong type"+        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]+      & expectFailure "Expected: nat"+  , testContractCoversEntrypoints+      "testContractCoversEntrypoints fails on missing entrypoints"+        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]+      & expectFailure "Missing entrypoints in the contract: do123"+  ]++test_ContractMatchEntrypoints :: [TestTree]+test_ContractMatchEntrypoints =+  [ testContractMatchesEntrypoints+      "testContractMatchesEntrypoints works as expected" (dummyContract @MyEntrypoints1) epSpecFull+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints fails on wrong type"+        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]+      & expectFailure "Expected: nat"+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints fails on missing entrypoints"+        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]+      & expectFailure "Missing entrypoints in the contract: do123"+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints fails on extraneous entrypoints"+        (dummyContract @MyEntrypoints1) epSpecPartial+      & expectFailure "Extraneous entrypoints in the contract: do4:\+                      \ pair (unit %param1) (bytes %param2)"+  ]++test_ContractMatchEntrypointsT :: [TestTree]+test_ContractMatchEntrypointsT =+  [ testContractMatchesEntrypointsT @MyEntrypoints1+      "testContractMatchesEntrypointsT works as expected" (dummyContract @MyEntrypoints1)+  , testContractMatchesEntrypointsT @MyEntrypoints2+      "testContractMatchesEntrypointsT fails on extra entrypoints" (dummyContract @MyEntrypoints1)+      & expectFailure "Extraneous entrypoints in the contract"+  ]++test_ContractCoverEntrypointsT :: [TestTree]+test_ContractCoverEntrypointsT =+  [ testContractCoversEntrypointsT @MyEntrypoints2+      "testContractCoversEntrypointsT works on partial spec" (dummyContract @MyEntrypoints1)+  , testContractCoversEntrypointsT @MyEntrypoints1+      "testContractCoversEntrypointsT works on full spec" (dummyContract @MyEntrypoints1)+  ]
+ test/TestSuite/Cleveland/NewAddressCheck.hs view
@@ -0,0 +1,61 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.NewAddressCheck+  ( test_AddressesReuse+  , test_NewAddressCheck+  ) where++import Test.Tasty++import Morley.Tezos.Core+import Test.Cleveland++test_AddressesReuse :: TestTree+test_AddressesReuse =+  -- If we start hitting this check, then we have to revise the fact that+  -- 'newAddress' does not always put money on the generated address.+  -- If probability of generating the same address twice is low, then+  -- we better always blindly transfer some money to new addresses.+  testScenario "Address generation is deterministic" $ scenario do+    addr1 <- newAddress "test"+    addr2 <- newAddress "test"++    addr1 @== addr2++test_NewAddressCheck :: [TestTree]+test_NewAddressCheck =+  [ testScenario "Newly created address gets money if it had low balance" $ scenario do+      test <- newAddress "test"+      test2 <- newAddress "test2"++      balance <- getBalance test+      let+        -- Prepare to spend most of the money (about 4/5 of the current balance)+        (toRemain, _) = balance `divModMutezInt` (5 :: Int) ?: error "Bad div"+        toSpend = balance - toRemain++      transferMoney test2 toSpend+        & withSender test++      balance2 <- getBalance test+      assert (balance2 <= toRemain) $+        "Sanity check failed. Something went wrong, is test broken?"++      -- creating the same address to check how balance replenishes+      _ <- newAddress "test"++      balance3 <- getBalance test+      checkCompares balance3 (>) toRemain++  , testScenario "Newly created address does not get money if it has enough" $ scenario do+      test <- newAddress "test"++      initialBalance <- getBalance test++      -- creating the same address to check that no extra money are put on it+      _ <- newAddress "test"++      getBalance test @@== initialBalance+  ]
+ test/TestSuite/Cleveland/OperationReplay.hs view
@@ -0,0 +1,32 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.OperationReplay+  ( test_replayOrigination_fails+  , test_replayTransfer_fails+  ) where++import Test.Tasty++import Morley.Tezos.Address (Address)+import Test.Cleveland+import Test.Util.Contracts+import TestSuite.Util (idContract, shouldFailWithMessage)++test_replayTransfer_fails :: TestTree+test_replayTransfer_fails =+  testScenarioOnEmulator "Transfer operation replay is prohibited" $ scenarioEmulated do+    dummyAddress <- chAddress <$> originateSimple @() @() "dummy" () idContract+    contract <- importContract @Address @() @() (contractsDir </> "replay_transfer.tz")+    replayTransfer <- originateSimple "replayTransfer" () contract+    call replayTransfer CallDefault dummyAddress+      & shouldFailWithMessage "Operation replay attempt"++test_replayOrigination_fails :: TestTree+test_replayOrigination_fails =+  testScenarioOnEmulator "Origination operation replay is prohibited" $ scenarioEmulated do+    contract <- importContract @() @() @() (contractsDir </> "replay_origination.tz")+    replayOrigination <- originateSimple "replayOrigination" () contract+    call replayOrigination CallDefault ()+      & shouldFailWithMessage "Operation replay attempt"
+ test/TestSuite/Cleveland/PrefixNetworkScenario.hs view
@@ -0,0 +1,49 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.PrefixNetworkScenario+  ( test_PrefixNetworkScenario+  ) where++import Data.Fixed (Nano)+import Data.Text (takeEnd)+import Data.Time.Clock.POSIX+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@=?))++import Morley.Client as Client+import Morley.Client.TezosClient.Types (tceAliasPrefixL)+import Morley.Tezos.Crypto (SecretKey, detSecretKey)+import Test.Cleveland+import Test.Cleveland.Internal.Abstract (HasClevelandCaps(moneybagL), Moneybag(Moneybag))+import Test.Cleveland.Internal.Client+  (neMoneybagAliasL, neMorleyClientEnvL, neSecretKeyL, runClevelandT)+import Test.Cleveland.Tasty (modifyNetworkEnv, whenNetworkEnabled)++aliasName :: Alias+aliasName = mkAlias "testMoneybagAlias"++aliasPrefix :: Text+aliasPrefix = "testPrefix"++mangleNetworkEnv :: SecretKey -> TestTree -> TestTree+mangleNetworkEnv sk = modifyNetworkEnv $+    (neMorleyClientEnvL . mceTezosClientL . tceAliasPrefixL .~ Just aliasPrefix)+  . (neSecretKeyL .~ Just sk)+  . (neMoneybagAliasL .~ aliasName)++test_PrefixNetworkScenario :: IO TestTree+test_PrefixNetworkScenario = do+  -- use 7 digits of the current POSIX time in nanoseconds to generate seed+  -- this ensures we test for a fresh key more often than not+  -- taking 7 digits ensures that we're generating Ed25519 key.+  seed <- encodeUtf8 . takeEnd 7 . show @Text . realToFrac @_ @Nano <$> getPOSIXTime+  let key = detSecretKey seed+  pure $ mangleNetworkEnv key $ whenNetworkEnabled $ \withEnv ->+    testCase "Moneybag alias is not affected by alias prefix" $ withEnv $ \env -> do+      Moneybag moneybagAddress <- runClevelandT env $ view moneybagL++      actualAlias <- runMorleyClientM (neMorleyClientEnv env) $+        Client.getAlias $ AddressResolved moneybagAddress+      actualAlias @=? aliasName
+ test/TestSuite/Cleveland/PrettyFailWith.hs view
@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.PrettyFailWith+  ( test_PrettyFailWith+  ) where++import Lorentz (Contract, car, defaultContract, failWith, nil, pair, sender, (#))++import Fmt (fmt, (+|), (|+))+import Test.Tasty (TestTree)++import Test.Cleveland+import TestSuite.Util++test_PrettyFailWith :: TestTree+test_PrettyFailWith = testScenarioOnEmulator "FailWith shows its argument using human-readable representation" $ scenarioEmulated do+  addr <- newFreshAddress auto+  withSender addr do+    cont <- originateSimple "failing" () failing+    call cont CallDefault () &+      shouldFailWithMessage (fmt $ "failed with: \"" +| addr |+ "\"")++failing :: Contract () () ()+failing = defaultContract $ car # sender # failWith # nil # pair
+ test/TestSuite/Cleveland/PublicKeyToAddress.hs view
@@ -0,0 +1,49 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Test for the calculation of an address from its public key. See [#354]+module TestSuite.Cleveland.PublicKeyToAddress+  ( test_publicKeyToAddress+  ) where++import Hedgehog (forAll, property, withTests)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog (testProperty)+import qualified Unsafe (fromJust)++import Lorentz as L hiding (comment)+import Test.Cleveland+import Test.Cleveland.Instances ()+import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAliasHint(..))++publicKeyToAddress :: Contract PublicKey (Maybe Address) ()+publicKeyToAddress = defaultContract $+  L.car #+  L.hashKey #+  L.implicitAccount #+  L.address #+  L.some #+  L.nil #+  L.pair++test_publicKeyToAddress :: TestTree+test_publicKeyToAddress =+  testProperty "The address is calculated correctly from the given public key" $+    withTests 200 $ property $ do+      aliasHint <- fromString <$> (forAll $ Gen.string (Range.linear 0 100) Gen.unicode)+      testScenarioProps $ scenario $ scenario' aliasHint++scenario' :: (MonadCleveland caps m) => AliasHint -> m ()+scenario' aliasHint = do+  c <- originateSimple @PublicKey @(Maybe Address) "publicKeyToAddress" Nothing publicKeyToAddress++  addr1 <- newAddress $ SpecificAliasHint aliasHint+  addr1pk <- getPublicKey addr1++  call c CallDefault addr1pk+  addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c++  addr1 @== addr2
+ test/TestSuite/Cleveland/RefillableAddress.hs view
@@ -0,0 +1,94 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.RefillableAddress+  ( test_AddressRefills+  , test_AddressDoesntRefill+  , test_RefillFailure+  ) where++import qualified Lorentz as L++import Test.Tasty++import Test.Cleveland++import Test.Util.Contracts+import TestSuite.Util (shouldFailWithMessage)++test_AddressRefills :: [TestTree]+test_AddressRefills =+  [ testScenario "A refillable address refills when transfer amount > balance" $ scenario do+      refillableAddr <- refillable $ newAddress "refillable"+      receiver <- newFreshAddress auto++      balanceSender <- getBalance refillableAddr++      withSender refillableAddr do+        transferMoney receiver (balanceSender + 1000) -- obviously more than sender has++      getBalance receiver @@== (balanceSender + 1000)+  , testScenario "A refillable address refills when transfer amount == balance - 1 μtz" $ scenario do+      refillableAddr <- refillable $ newAddress "refillable"+      receiver <- newFreshAddress auto++      balanceSender <- getBalance refillableAddr++      withSender refillableAddr do+        transferMoney receiver (balanceSender - 1) -- also would fail without auto-refill, due to fees+        -- NOTE: the test crashes currently when transfer amount = balance; it seems like a+        -- bug in the local chain code. Theoretically, this test should work either way.++      getBalance receiver @@== (balanceSender - 1)+  , testScenario "A refillable address refills during contract origination" $ scenario do+      refillableAddr <- refillable $ newAddress "refillable"+      soBigContract <- importContract @() @() @() $ contractsDir </> "so_big.tz"+      -- storage burn should be at least >= 1 XTZ due to the contract size+      -- however, since 'refillableAddr' has at least 0.5 XTZ after 'refillable'+      -- we also transfer 0.5 XTZ to the contract; this ensures we're overbudget.+      void $ withSender refillableAddr $ originate $ OriginateData+        { odName = "so_big"+        , odBalance = 0.5e6+        , odContract = soBigContract+        , odStorage = ()+        }+  ]++test_AddressDoesntRefill :: [TestTree]+test_AddressDoesntRefill =+  [ testScenarioOnEmulator "A non-refillable address doesn't refill" $ scenarioEmulated (nonRefillableScenario emulatedError)+  , testScenarioOnNetwork "A non-refillable address doesn't refill" $ scenario (nonRefillableScenario networkError)+  ]+  where+  emulatedError = "doesn't have enough funds"+  networkError = "too low"++nonRefillableScenario :: MonadCleveland caps m => String -> m ()+nonRefillableScenario errorMsg = do+  nonRefillable <- newFreshAddress auto+  receiver <- newFreshAddress auto++  -- needed to reveal `nonRefillable`+  transferMoney nonRefillable 1++  shouldFailWithMessage errorMsg $+    withSender nonRefillable $ transferMoney receiver 100++test_RefillFailure :: TestTree+test_RefillFailure = testScenario "Refill should succeed even if moneybag can't make the call"+  $ scenario do+    owner <- refillable $ newFreshAddress "owner"+    transferMoney owner 400 -- a little more than revelation fee to avoid empty_implicit_contract+    contract <- originateSimple @() @L.Address @() "contract" owner $ L.defaultContract $+          L.cdr+      L.# L.dup+      L.# L.sender+      L.# L.ifEq+        (L.nil L.# L.pair)+        (L.push @L.MText "Sender is not owner" L.# L.failWith)+    balance1 <- getBalance owner+    withSender owner $ call contract CallDefault ()+    balance2 <- getBalance owner+    -- check that owner was in fact refilled+    checkCompares balance1 (<=) balance2
+ test/TestSuite/Cleveland/StorageCheck.hs view
@@ -0,0 +1,128 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE OverloadedLists #-}++module TestSuite.Cleveland.StorageCheck+  ( test_GetStorage+  , test_GetFullStorage+  , test_GetFullStorageConditional+  , test_GetSomeStorage+  , test_AnnotationsArePreserved+  ) where+++import Control.Lens+import Fmt (Buildable(..), GenericBuildable(..))+import System.FilePath ((</>))+import Test.Tasty (TestTree)++import Lorentz hiding (comment, contract)+import Morley.Michelson.Typed (isoValue)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.AnnotatedValue++import Test.Cleveland+import Test.Cleveland.Lorentz (embedContract)+import Test.Util.Contracts (contractsDir)+import TestSuite.Util (BigMapInStorage(..), idContract, saveInStorageContract)++data Storage = Storage+  { _stField1 :: Natural+  , _stField2 :: BigMap Natural MText+  }+  deriving stock (Generic, Show, Eq)+  deriving anyclass (IsoValue, HasAnnotation)+  deriving Buildable via GenericBuildable Storage++deriveRPC "Storage"++test_GetStorage :: TestTree+test_GetStorage =+  testScenario "getStorage returns the contract's storage" $ scenario do+    addr <- originateSimple+      "save parameter in storage"+      (1 :: Natural)+      saveInStorageContract++    comment "checking initial storage"+    getStorage addr @@== 1++    transfer TransferData+      { tdTo = addr+      , tdAmount = 100+      , tdEntrypoint = DefEpName+      , tdParameter = 2 :: Natural+      }++    comment "storage is updated after transfer"+    getStorage addr @@== 2++test_GetFullStorage :: TestTree+test_GetFullStorage =+  testScenarioOnEmulator "getFullStorage returns storage with big_map's contents" $ scenarioEmulated do+    let initialStorage =+          Storage+            { _stField1 = 23+            , _stField2 =+                [ (1, "a")+                , (2, "b")+                ]+            }+    addr <- originateSimple @() @Storage "test" initialStorage idContract+    getFullStorage addr @@== initialStorage++test_GetFullStorageConditional :: TestTree+test_GetFullStorageConditional =+  testScenario "getStorage/getFullStorage can work conditionally" $ scenario do+    let initialStorage =+          Storage+            { _stField1 = 23+            , _stField2 =+                [ (1, "a")+                , (2, "b")+                ]+            }+    addr <- originateSimple @() @Storage "test" initialStorage idContract+    getRunMode >>= \case+      NetworkMode -> _stField1RPC <$> getStorage addr @@== 23+      EmulationMode -> getFullStorage addr @@== initialStorage++test_GetSomeStorage :: TestTree+test_GetSomeStorage = testScenario "getSomeStorage is consistent with getStorage" $ scenario do+  addr <- originateSimple @() @Storage "test" (Storage 1 [(2, "a")]) idContract+  storage <- getStorage addr+  someStorage <- getSomeStorage addr++  someStorage ^? castTo @StorageRPC . value . from isoValue @== Just (toVal storage)++test_AnnotationsArePreserved :: [TestTree]+test_AnnotationsArePreserved =+  [ testScenario "importUntypedContract" $ scenario do+      contract <- importUntypedContract $ contractsDir </> "big_map_in_storage.tz"+      let initialStorage = (one (101, 102), 103) :: (BigMap Integer Integer, Natural)+      addr <- originateUntypedSimple "contract" (T.untypeValue $ T.toVal initialStorage) contract+      checkAnnotationsArePreserved addr+  , testScenario "importContract" $ scenario do+      contract <- importContract @Integer @(BigMap Integer Integer, Natural) @() $ contractsDir </> "big_map_in_storage.tz"+      let initialStorage = (one (101, 102), 103)+      originateSimple "contract" initialStorage contract >>= checkAnnotationsArePreserved+  , testScenario "importContract with a user-defined storage" $ scenario do+      contract <- importContract @Integer @BigMapInStorage @() $ contractsDir </> "big_map_in_storage.tz"+      let initialStorage = BigMapInStorage (one (101, 102)) 103+      addr <- originateSimple "contract" initialStorage contract+      checkAnnotationsArePreserved addr+  , testScenario "embedContract" $ scenario do+      let contract = $$(embedContract @Integer @BigMapInStorage @() $ contractsDir </> "big_map_in_storage.tz")+      let initialStorage = BigMapInStorage (one (101, 102)) 103+      addr <- originateSimple "contract" initialStorage contract+      checkAnnotationsArePreserved addr+  ]+  where+    checkAnnotationsArePreserved :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m ()+    checkAnnotationsArePreserved addr = do+      storage <- getSomeStorage addr+      storage ^? field "field2" . castTo @Natural . value @== Just 103+      let bigMapId = storage ^?! field "field1" . castTo @(BigMapId Integer Integer) . value+      getBigMapValue bigMapId 101 @@== 102
+ test/TestSuite/Cleveland/StorageWithBigMaps.hs view
@@ -0,0 +1,244 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE OverloadedLists #-}++module TestSuite.Cleveland.StorageWithBigMaps+  ( test_UniqueIDs+  , test_getAllBigMapValues+  , test_getAllBigMapValues_ConsistentWith_getBigMapValue+  , test_getBigMapSize+  , test_GetBigMapValue+  , test_GetBigMapValueMaybe_InvalidBigMapId+  , test_GetBigMapValueMaybe_InvalidKey+  , test_ID_BecomesInvalid+  ) where++import Lorentz as L hiding (assert)++import Control.Lens (to)+import Data.Data (Data)+import Data.Data.Lens (biplate)+import Fmt (Builder, blockListF, unlinesF)+import Test.Tasty (TestTree)+import qualified Unsafe (fromIntegral)++import Test.Cleveland+import TestSuite.Util (idContract, saveInStorageContract)++data BigMaps = BigMaps+  { _bmBigMap :: BigMap Natural Natural+  , _bmOpt :: Maybe (BigMap Natural Natural)+  , _bmList :: [BigMap Natural Natural]+  , _bmPair :: (BigMap Natural Natural, BigMap Natural Natural)+  , _bmLeft :: Either (BigMap Natural Natural) (BigMap Natural Natural)+  , _bmRight :: Either (BigMap Natural Natural) (BigMap Natural Natural)+  , _bmMap :: Map Natural (BigMap Natural Natural)+  }+  deriving stock (Generic)+  deriving anyclass (IsoValue, HasAnnotation)++deriveRPC "BigMaps"+deriving stock instance Data BigMapsRPC++-- | There are 5 ways of creating big_maps on the chain:+--+-- * Originate a contract with big_maps in its initial storage.+-- * Call a contract with a parameter with big_maps in it, and then save those big_maps in the contract's storage.+-- * While executing a contract's code:+--     * execute the `EMPTY_BIG_MAP` instruction.+--     * execute the `DUP` instruction to duplicate a big_map or a value containing big_map(s).+--     * execute the `DUP n` instruction to duplicate a big_map or a value containing big_map(s).+--+-- This contract does all of those things.+createBigMaps :: Contract BigMaps BigMaps ()+createBigMaps = defaultContract $+  unpair+  # L.dip (getField #_bmList)++  -- Extract all the big_maps that were passed in through the transfer's parameter+  -- and save them in the contract's storage.+  # extractBigMaps++  -- Create new big_maps via: EMPTY_BIG_MAP, DUP, DUP n.+  -- Note: instead of duplicating a `big_map k v`, we duplicate a `list (big_map k v)` to ensure+  -- the algorithm works even on deeply nested big_maps.+  # nil # emptyBigMap # cons+  # dup+  # dupN @2++  -- Merge all the big_maps into the storage's `_bmList` field+  # joinList # joinList # joinList # joinList+  # setField #_bmList++  # nil @Operation+  # pair++  where+    joinList :: List a : List a : s :-> List a : s+    joinList = L.iter cons++    extractBigMaps :: BigMaps : s :-> List (BigMap Natural Natural) : s+    extractBigMaps =+      L.listE+        [ L.getField #_bmBigMap+        , L.getField #_bmOpt # L.assertSome @MText "Expected Some, got None"+        , getField #_bmLeft # assertLeft @MText "Expected Left, got Right"+        , getField #_bmRight # assertRight @MText "Expected Right, got Left"+        ]+      # L.swap++      # getField #_bmList+      # L.swap # dip joinList++      # getField #_bmPair+      # L.swap # dip (unpair # dip cons # cons)++      # getField #_bmMap+      # L.swap # dip (iter (cdr # cons))++      # L.drop++test_UniqueIDs :: TestTree+test_UniqueIDs =+  testScenario "all big_maps have unique IDs" $ scenario do+    let bm = [(1, 1)]+    let bigMaps =+          BigMaps+            bm+            (Just bm)+            [bm]+            (bm, bm)+            (Left bm)+            (Right bm)+            [(1, bm)]++    -- Originate the contract.+    -- Call the contract twice, to make sure the BigMapCounter is incremented+    -- inbetween operations.+    addr <- originateSimple "create-big-maps" bigMaps createBigMaps+    call addr CallDefault bigMaps+    call addr CallDefault bigMaps++    finalStorage <- getStorage addr+    let bigMapIds = finalStorage ^.. biplate @_ @(BigMapId Natural Natural) . to unBigMapId++    -- The contract's storage should have 30 big_maps in total.+    --   * 8 created via the contract's initial storage,+    --   * For each contract call:+    --       * 8 that were passed in through the call's parameter+    --       * 1 via `EMPTY_BIG_MAP`, 1 via `DUP`, 1 via `DUP n`+    length bigMapIds @== 30++    assert (bigMapIds == ordNub bigMapIds) $+      unlinesF @[] @Builder+        [ "Expected all big_maps to have unique IDs, but some duplicates were found:"+        , blockListF (sort bigMapIds)+        ]++test_GetBigMapValue :: TestTree+test_GetBigMapValue =+  testScenario "getBigMapValue retrieves the correct value" $ scenario do+    contract1 <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText)+      "contract1"+      ([(1, "a"), (2, "b")], [(1, "c"), (2, "d")])+      idContract+    contract2 <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText)+      "contract1"+      ([(1, "e"), (2, "f")], [(1, "g"), (2, "h")])+      idContract++    (bigMap1, bigMap2) <- getStorage contract1+    (bigMap3, bigMap4) <- getStorage contract2++    getBigMapValue bigMap1 1 @@== "a"+    getBigMapValue bigMap1 2 @@== "b"+    getBigMapValue bigMap2 1 @@== "c"+    getBigMapValue bigMap2 2 @@== "d"+    getBigMapValue bigMap3 1 @@== "e"+    getBigMapValue bigMap3 2 @@== "f"+    getBigMapValue bigMap4 1 @@== "g"+    getBigMapValue bigMap4 2 @@== "h"++test_getBigMapSize :: TestTree+test_getBigMapSize =+  testScenario "getBigMapSize retrieves the correct size" $ scenario do+    let+      bmList = sampleList ++ [(5, "d")]+      expectedSize = Unsafe.fromIntegral @Int @Natural $ length bmList+    c <- originateSimple @() @(BigMap Integer MText) "contract" (mkBigMap bmList) idContract++    bigMapId <- getStorage c+    bmSize <- getBigMapSize bigMapId++    bmSize @== expectedSize++test_getAllBigMapValues :: TestTree+test_getAllBigMapValues =+  testScenario "getAllBigMapValues retrieves the correct values" $ scenario do+    let bmValues = snd <$> sampleList+    c <- originateSimple @() @(BigMap Integer MText) "contract" (mkBigMap sampleList) idContract++    bigMapId <- getStorage c+    vs <- getAllBigMapValues bigMapId++    sort vs @== sort bmValues++test_getAllBigMapValues_ConsistentWith_getBigMapValue :: TestTree+test_getAllBigMapValues_ConsistentWith_getBigMapValue =+  testScenario "results of 'getAllBigMapValues' and 'getBigMapValue' are consistent" $ scenario do+    c <- originateSimple @() @(BigMap Integer MText)+      "contract"+      (mkBigMap sampleList)+      idContract++    bigMapId <- getStorage c++    vs <- forM sampleList $ \(k, _) -> getBigMapValue bigMapId k+    vs' <- getAllBigMapValues bigMapId++    sort vs @== sort vs'+    length vs @== length vs'++test_GetBigMapValueMaybe_InvalidBigMapId :: TestTree+test_GetBigMapValueMaybe_InvalidBigMapId =+  testScenario "getBigMapValueMaybe returns 'Nothing' when big_map ID is invalid" $ scenario do+    let invalidBigMapId = 2 ^ (99 :: Natural)+    getBigMapValueMaybe @Integer @Integer invalidBigMapId 0 @@== Nothing++test_GetBigMapValueMaybe_InvalidKey :: TestTree+test_GetBigMapValueMaybe_InvalidKey =+  testScenario "getBigMapValueMaybe returns 'Nothing' when key is invalid" $ scenario do+    addr <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText)+      "contract1"+      ([(1, "a"), (2, "b")], [(2, "c"), (3, "d")])+      idContract++    (bigMap1, bigMap2) <- getStorage addr++    getBigMapValueMaybe bigMap1 3 @@== Nothing+    getBigMapValueMaybe bigMap2 1 @@== Nothing++test_ID_BecomesInvalid :: TestTree+test_ID_BecomesInvalid =+  testScenario "big_map IDs become invalid once the big_map is removed from the storage" $ scenario do+    addr <- originateSimple @(BigMap Integer MText)+      "contract1"+      [(1, "a")]+      saveInStorageContract++    bigMapId <- getStorage addr+    getBigMapValueMaybe bigMapId 1 @@== Just "a"++    -- Replace the big_map in the contract's storage with a new big_map (with same contents).+    call addr CallDefault [(1, "a")]++    -- The old big_map ID should now be invalid.+    getBigMapValueMaybe bigMapId 1 @@== Nothing++    -- The new big_map in the contract's storage should have a different ID than the first big_map.+    fmap unBigMapId (getStorage addr) @@/= unBigMapId bigMapId++sampleList :: [(Integer, MText)]+sampleList = [(1, "a"), (2, "b"), (3, "c"), (4, "d")]
+ test/TestSuite/Cleveland/Tasty.hs view
@@ -0,0 +1,112 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Tasty+  ( test_Memoize+  , test_OptionsCombinations+  ) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options (OptionSet, singleOption)+import Test.Tasty.Runners (TreeFold(..), foldTestTree, trivialFold)++import Test.Cleveland.Internal.Scenario+import Test.Cleveland.Tasty.Internal+  (loadOptionSwitcher, memoize, testScenario, testScenarioOnEmulator, testScenarioOnNetwork)+import Test.Cleveland.Tasty.Internal.Options (RunModeOpt(..))++test_Memoize :: TestTree+test_Memoize =+  testGroup "memoize"+    [ testCase "is lazy" $ do+        ioref <- newIORef @_ @Int 1++        _action <- memoize (modifyIORef ioref succ)++        val <- readIORef ioref+        val @?= 1++    , testCase "writes only once to cache" $ do+        ioref <- newIORef @_ @Int 1++        action <- memoize (modifyIORef ioref succ)+        action+        action+        action++        val <- readIORef ioref+        val @?= 2+    ]++test_OptionsCombinations :: TestTree+test_OptionsCombinations =+  testGroup "Test possible option combinations" $+    [ testGroup "Tests when CI is Unset" $+      [ testCase "Mode is not specified" $+        getTestNames mempty sampleTestTreeUnset @?= onlyEmulatorResult ++ hunitResult+      , testCase "RunAllMode is used" $+        getTestNames (singleOption RunAllMode)  sampleTestTreeUnset @?= fullResult ++ hunitResult+      , testCase "NoRunNetworkMode is used" $+        getTestNames (singleOption DisableNetworkMode)  sampleTestTreeUnset @?= onlyEmulatorResult ++ hunitResult+      , testCase "RunOnlyNetworkMode is used" $+        getTestNames (singleOption OnlyNetworkMode)  sampleTestTreeUnset @?= onlyNetworkResult+      ]+    , testGroup "Tests when CI is Set" $+      [ testCase "Mode is not specified" $+        getTestNames mempty sampleTestTreeSet @?= fullResult ++ hunitResult+      , testCase "RunAllMode is used" $+        getTestNames (singleOption RunAllMode)  sampleTestTreeSet @?= fullResult ++ hunitResult+      , testCase "NoRunNetworkMode is used" $+        getTestNames (singleOption DisableNetworkMode)  sampleTestTreeSet @?= onlyEmulatorResult ++ hunitResult+      , testCase "RunOnlyNetworkMode is used" $+        getTestNames (singleOption OnlyNetworkMode)  sampleTestTreeSet @?= onlyNetworkResult+      ]+    ]+  where+    getTestNames :: OptionSet -> TestTree -> [String]+    getTestNames =+      foldTestTree+        trivialFold+          { foldSingle = \_ name _ -> [name]+          , foldGroup = \_opts n l -> map ((n ++ ".") ++) l+          }+    sampleTestTreeSet :: TestTree+    sampleTestTreeSet = loadOptionSwitcher True $ testGroup "Tests"+      [ testScenario "test on both network and emulator" $ scenario pass+      , testScenarioOnEmulator "test only on emulator" $ scenarioEmulated pass+      , testScenarioOnNetwork "test only on network" $ scenario pass+      , testCase "hunit test" pass+      ]++    sampleTestTreeUnset :: TestTree+    sampleTestTreeUnset = loadOptionSwitcher False $ testGroup "Tests"+      [ testScenario "test on both network and emulator" $ scenario pass+      , testScenarioOnEmulator "test only on emulator" $ scenarioEmulated pass+      , testScenarioOnNetwork "test only on network" $ scenario pass+      , testCase "hunit test" pass+      ]++    fullResult :: [String]+    fullResult =+      [ "Tests.test on both network and emulator.On emulator"+      , "Tests.test on both network and emulator.On network"+      , "Tests.test only on emulator.On emulator"+      , "Tests.test only on network.On network"+      ]++    onlyEmulatorResult :: [String]+    onlyEmulatorResult =+      [ "Tests.test on both network and emulator.On emulator"+      , "Tests.test only on emulator.On emulator"+      ]++    onlyNetworkResult :: [String]+    onlyNetworkResult =+      [ "Tests.test on both network and emulator.On network"+      , "Tests.test only on network.On network"+      ]++    hunitResult :: [String]+    hunitResult = ["Tests.hunit test"]
+ test/TestSuite/Cleveland/Tasty/Report.hs view
@@ -0,0 +1,76 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Tasty.Report+  ( test_formatError+  , unit_formatError_fails_gracefully_when_callstack_loc_points_to_another_package+  ) where++import Data.Char (isSpace)+import qualified Data.Text as Text+import Fmt (build, indentF, pretty, unlinesF)+import GHC.Stack (SrcLoc(..), fromCallSiteList)+import System.FilePath ((</>))+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options (singleOption)+import Test.Tasty.Runners (Result(resultDescription))++import Test.Cleveland+import Test.Cleveland.Tasty.Internal.Options (ContextLinesOpt(ContextLinesOpt))+import Test.Cleveland.Tasty.Internal.Report (formatError)++import TestSuite.Cleveland.Tasty.Report.Examples (reportExamples)+import TestSuite.Util (runViaTastyOnEmulator)++test_formatError :: TestTree+test_formatError =+  testGroup "formatError" $+    fmap checkResultDescription reportExamples++checkResultDescription :: (TestName, EmulatedT PureM (), Text) -> TestTree+checkResultDescription (testName, scenario', expectedErr) =+  runViaTastyOnEmulator testName (singleOption (ContextLinesOpt 1)) scenario' \tastyResult -> do+    let+      -- Some error lines might have trailing whitespace, we can ignore it here.+      strippedErr =+        lines (toText $ resultDescription tastyResult)+        & fmap (Text.dropWhileEnd isSpace)+        & unlines++    unless (expectedErr `Text.isPrefixOf` strippedErr) $+      assertFailure $+        pretty $ unlinesF+          [ "Expected the report to start with:"+          , indentF 4 $ build expectedErr+          , "But got:"+          , indentF 4 $ build strippedErr+          ]+++unit_formatError_fails_gracefully_when_callstack_loc_points_to_another_package :: Assertion+unit_formatError_fails_gracefully_when_callstack_loc_points_to_another_package = do+  builder <-+    formatError+      1+      (fromCallSiteList+        [ ("expectCustomError_"+          , SrcLoc+              { srcLocPackage = "pkg"+              , srcLocModule = "Module"+              , srcLocFile = "src" </> "invalid" </> "path"+              , srcLocStartLine = 1, srcLocStartCol = 1, srcLocEndLine = 1, srcLocEndCol = 1+              }+          )+        ]+      )+      "err msg"++  pretty builder @?=+    unlines+      [ "err msg"+      , ""+      , "CallStack (from HasCallStack):"+      , toText ("  expectCustomError_, called at src" </> "invalid" </> "path:1:1 in pkg:Module")+      ]
+ test/TestSuite/Cleveland/Tasty/Report/Examples.hs view
@@ -0,0 +1,243 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Tasty.Report.Examples+  ( reportExamples+  ) where++import System.FilePath ((</>))++import Morley.Tezos.Address+import Morley.Util.Interpolate+import Test.Cleveland++++++----------------------------------------------------------------------------+-- Examples+----------------------------------------------------------------------------++example1 :: EmulatedT PureM ()+example1 = void $ signBytes "" unknownAddr++example1ExpectedErr :: Text+example1ExpectedErr =+  [itu|+   ┏━━ #{reportExamplesPath} ━━━+23 ┃ example1 :: EmulatedT PureM ()+24 ┃ example1 = void $ signBytes "" unknownAddr+   ┃                   ^^^^^^^^^^^^^^^^^^^^^^^^+   ┃                   | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+25 ┃++CallStack (from HasCallStack):+  |]++----------------------------------------------------------------------------+-- Examples with helper functions+----------------------------------------------------------------------------++exampleWithHelperFunction1 :: EmulatedT PureM ()+exampleWithHelperFunction1 = exampleWithHelperFunction1Helper++exampleWithHelperFunction1Helper :: EmulatedT PureM ()+exampleWithHelperFunction1Helper = void $ signBytes "" unknownAddr++exampleWithHelperFunction1ExpectedErr :: Text+exampleWithHelperFunction1ExpectedErr =+  [itu|+     ┏━━ #{reportExamplesPath} ━━━+  46 ┃ exampleWithHelperFunction1Helper :: EmulatedT PureM ()+  47 ┃ exampleWithHelperFunction1Helper = void $ signBytes "" unknownAddr+     ┃                                           ^^^^^^^^^^^^^^^^^^^^^^^^+     ┃                                           | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  48 ┃++  CallStack (from HasCallStack):+  |]++exampleWithHelperFunction2 :: EmulatedT PureM ()+exampleWithHelperFunction2 = exampleWithHelperFunction2Helper++exampleWithHelperFunction2Helper :: HasCallStack => EmulatedT PureM ()+exampleWithHelperFunction2Helper = withFrozenCallStack $ void $ signBytes "" unknownAddr++exampleWithHelperFunction2ExpectedErr :: Text+exampleWithHelperFunction2ExpectedErr =+  [itu|+     ┏━━ #{reportExamplesPath} ━━━+  62 ┃ exampleWithHelperFunction2 :: EmulatedT PureM ()+  63 ┃ exampleWithHelperFunction2 = exampleWithHelperFunction2Helper+     ┃                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+     ┃                              | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  64 ┃++  CallStack (from HasCallStack):+  |]++----------------------------------------------------------------------------+-- Example with no callstack frames+----------------------------------------------------------------------------++exampleNoCallStack1 :: EmulatedT PureM ()+exampleNoCallStack1 = withFrozenCallStack $ void $ signBytes "" unknownAddr++exampleNoCallStack1ExpectedErr :: Text+exampleNoCallStack1ExpectedErr =+  [i|Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z|]++++----------------------------------------------------------------------------+-- Example with errors spanning across multiple lines+----------------------------------------------------------------------------++exampleMultipleLines1 :: EmulatedT PureM ()+exampleMultipleLines1 =+  void ( signBytes+           ""+           unknownAddr )++exampleMultipleLines1ExpectedErr :: Text+exampleMultipleLines1ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+   99 ┃ exampleMultipleLines1 =+  100 ┃   void ( signBytes+  101 ┃            ""+  102 ┃            unknownAddr )+      ┃          ^^^^^^^^^^^^^+      ┃          | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  103 ┃++  CallStack (from HasCallStack):+  |]++exampleMultipleLines2 :: EmulatedT PureM ()+exampleMultipleLines2 =+  void (   signBytes+         ""+           unknownAddr )++exampleMultipleLines2ExpectedErr :: Text+exampleMultipleLines2ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+  120 ┃ exampleMultipleLines2 =+  121 ┃   void (   signBytes+  122 ┃          ""+  123 ┃            unknownAddr )+      ┃          ^^^^^^^^^^^^^+      ┃          | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  124 ┃++  CallStack (from HasCallStack):+  |]++exampleMultipleLines3 :: EmulatedT PureM ()+exampleMultipleLines3 =+  void (   signBytes+           ""+         unknownAddr )++exampleMultipleLines3ExpectedErr :: Text+exampleMultipleLines3ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+  141 ┃ exampleMultipleLines3 =+  142 ┃   void (   signBytes+  143 ┃            ""+  144 ┃          unknownAddr )+      ┃          ^^^^^^^^^^^+      ┃          | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  145 ┃++  CallStack (from HasCallStack):+  |]++exampleMultipleLines4 :: EmulatedT PureM ()+exampleMultipleLines4 =+  void (      signBytes+                   ""+         unknownAddr   )++exampleMultipleLines4ExpectedErr :: Text+exampleMultipleLines4ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+  162 ┃ exampleMultipleLines4 =+  163 ┃   void (      signBytes+  164 ┃                    ""+  165 ┃          unknownAddr   )+      ┃          ^^^^^^^^^^^^^^+      ┃          | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  166 ┃++  CallStack (from HasCallStack):+  |]++exampleMultipleLines5 :: EmulatedT PureM ()+exampleMultipleLines5 =+  void (    signBytes+                     ""+         unknownAddr   )++exampleMultipleLines5ExpectedErr :: Text+exampleMultipleLines5ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+  183 ┃ exampleMultipleLines5 =+  184 ┃   void (    signBytes+  185 ┃                      ""+  186 ┃          unknownAddr   )+      ┃          ^^^^^^^^^^^^^^+      ┃          | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  187 ┃++  CallStack (from HasCallStack):+  |]++exampleMultipleLines6 :: EmulatedT PureM ()+exampleMultipleLines6 =+  void (    signBytes+                   ""+           unknownAddr   )++exampleMultipleLines6ExpectedErr :: Text+exampleMultipleLines6ExpectedErr =+  [itu|+      ┏━━ #{reportExamplesPath} ━━━+  204 ┃ exampleMultipleLines6 =+  205 ┃   void (    signBytes+  206 ┃                    ""+  207 ┃            unknownAddr   )+      ┃            ^^^^^^^^^^^+      ┃            | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z+  208 ┃++  CallStack (from HasCallStack):+  |]++unknownAddr :: Address+unknownAddr = unsafeParseAddress "tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z"++reportExamples :: [(String, EmulatedT PureM (), Text)]+reportExamples =+  [ ("example1", example1, example1ExpectedErr)+  , ("exampleWithHelperFunction1", exampleWithHelperFunction1, exampleWithHelperFunction1ExpectedErr)+  , ("exampleWithHelperFunction2", exampleWithHelperFunction2, exampleWithHelperFunction2ExpectedErr)+  , ("exampleNoCallStack1", exampleNoCallStack1, exampleNoCallStack1ExpectedErr)+  , ("exampleMultipleLines1", exampleMultipleLines1, exampleMultipleLines1ExpectedErr)+  , ("exampleMultipleLines2", exampleMultipleLines2, exampleMultipleLines2ExpectedErr)+  , ("exampleMultipleLines3", exampleMultipleLines3, exampleMultipleLines3ExpectedErr)+  , ("exampleMultipleLines4", exampleMultipleLines4, exampleMultipleLines4ExpectedErr)+  , ("exampleMultipleLines5", exampleMultipleLines5, exampleMultipleLines5ExpectedErr)+  , ("exampleMultipleLines6", exampleMultipleLines6, exampleMultipleLines6ExpectedErr)+  ]++reportExamplesPath :: Text+reportExamplesPath = fromString $+  "test" </> "TestSuite" </> "Cleveland" </> "Tasty" </> "Report" </> "Examples.hs"
+ test/TestSuite/Cleveland/Time.hs view
@@ -0,0 +1,71 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Time+  ( test_Time+  ) where++import Data.Time+import Test.Tasty+import Time++import Morley.Michelson.Runtime.Dummy (dummyNow)+import Morley.Tezos.Core as Tezos+import Test.Cleveland+import Test.Cleveland.Util++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++test_Time :: TestTree+test_Time =+  testGroup "time-related functions" $+    [ testGroup "advanceTime" $+      [ testGroup "advances time by at least the specified amount" $+          testDeltas <&> \delta ->+            testScenario (show delta) $ scenario do+              t0 <- getNow+              advanceTime delta+              t1 <- getNow+              let actualDelta = timestampToUTCTime t1 `diffUTCTime` timestampToUTCTime t0++              assert (actualDelta >= timeToNominalDiffTime delta) $+                mconcat+                  [ "Expected at least "+                  , show delta+                  , " to have passed, but only "+                  , show actualDelta+                  , " have passed."+                  ]++      , testGroup "advances time by exact amount (up to the nearest second) in the emulator" $+          testDeltas <&> \delta ->+            testScenarioOnEmulator (show delta) $ scenarioEmulated do+              t0 <- getNow+              advanceTime delta+              t1 <- getNow+              let actualDelta = timestampToUTCTime t1 `diffUTCTime` timestampToUTCTime t0++              assert (actualDelta == timeToNominalDiffTime (ceilingUnit delta)) $+                mconcat+                  [ "Expected exactly "+                  , show delta+                  , " to have passed, but "+                  , show actualDelta+                  , " have passed."+                  ]+      ]+    , testScenarioOnEmulator "initial time is 'dummyNow' in the emulator" $ scenarioEmulated do+        t0 <- getNow+        t0 @== dummyNow+    ]+  where+    testDeltas :: [Time Second]+    testDeltas =+      [ sec 0+      , sec 0.1+      , sec 0.9+      , sec 1+      , sec 2+      , sec 3+      ]
+ test/TestSuite/Cleveland/TransferCheck.hs view
@@ -0,0 +1,126 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.TransferCheck+  ( test_TransferFromContract+  , test_nonUnitParamToImplicitAccount_fails+  ) where++import Test.Tasty++import Lorentz ((#))+import qualified Lorentz as L+import Lorentz.Value+import Morley.Util.Named ((!))+import Test.Cleveland+import TestSuite.Util (idContract, shouldFailWithMessage)++test_TransferFromContract :: [TestTree]+test_TransferFromContract =+  [ testScenarioOnEmulator "Disallow transferring ꜩ when revealing a contract (#440)" $ scenarioEmulated do+      testRevealContract morleyMessage+  , testScenarioOnNetwork "Disallow transferring ꜩ when revealing a contract (#440)" $ scenario do+      testRevealContract rpcMessage++  , testScenarioOnEmulator "Disallow transferring ꜩ from an empty implicit account (#440)" $ scenario do+      testEmptyImplicitAccount morleyMessage+  , testScenarioOnNetwork "Disallow transferring ꜩ from an empty implicit account (#440)" $ scenario do+      testEmptyImplicitAccount rpcMessage+  , testScenario "Fails transfering 0tz to plain account" $ scenario+      $ testZeroTransactionFails+  , testScenario "Success transfering 0tz to a contract" $ scenario+      $ testZeroTransactionSuccess+  , testScenario "Allow transferring 0ꜩ from TRANSFER_TOKENS (#440)" $ scenario testEmptyTransfer+  ]+  where+    morleyMessage :: String+    morleyMessage = "Global transaction of funds (200 μꜩ) from an originated contract"++    rpcMessage :: String+    rpcMessage = "Contracts (rx) cannot be revealed"++    testRevealContract :: MonadCleveland caps m => String -> m ()+    testRevealContract expectedErrorMsg = do+      addr <- newAddress auto+      contractAddr <- originateSimple @() @() "rx" () idContract++      comment "give some funds to the originated contract"+      transferMoney contractAddr 200++      comment "fail when transferring from contract"+      transferMoney addr 200+        & withSender (toAddress contractAddr)+        & shouldFailWithMessage expectedErrorMsg++    testEmptyImplicitAccount :: MonadCleveland caps m => String -> m ()+    testEmptyImplicitAccount expectedErrorMsg = do+      testAddr <- newFreshAddress auto+      contractAddr <- originate OriginateData+        { odName = "rx"+        , odStorage = ()+        , odBalance = 500+        , odContract = idContract @() @()+        }++      comment "fail when transferring from contract"+      transferMoney testAddr 200+        & withSender (toAddress contractAddr)+        & shouldFailWithMessage expectedErrorMsg++    testEmptyTransfer :: MonadCleveland caps m => m ()+    testEmptyTransfer = do+      addr1 <- originateSimple "test1" () zeroTransferContract+      addr2 <- originateSimple "test2" () idContract+      call addr1 L.CallDefault (toTAddress addr2)++zeroTransferContract :: L.Contract (L.TAddress () ()) () ()+zeroTransferContract = L.defaultContract $+  L.car #+  L.pairE+    ( L.transferTokensE+        ! #contract do+           L.contract # L.assertSome [L.mt|Invalid contract address|]+        ! #amount do L.push zeroMutez+        ! #arg L.unit+      L.|:| L.nil+    , L.unit+    )++test_nonUnitParamToImplicitAccount_fails :: TestTree+test_nonUnitParamToImplicitAccount_fails =+  testScenario "`transfer` fails when param for an implicit account is not Unit" $ scenario do+    addr <- newFreshAddress "alias"+    transfer TransferData+      { tdTo = addr+      , tdAmount = 2+      , tdEntrypoint = DefEpName+      , tdParameter = (2 :: Natural)+      }+      & shouldFailWithMessage "Bad contract parameter for: "++testZeroTransactionFails :: MonadCleveland caps m => m ()+testZeroTransactionFails = do+  wallet <- newAddress "wallet"+  let+    transferData = TransferData+      { tdTo = wallet+      , tdAmount = 0+      , tdEntrypoint = DefEpName+      , tdParameter = ()+      }++  expectTransferFailure emptyTransaction (transfer transferData)++testZeroTransactionSuccess :: MonadCleveland caps m => m ()+testZeroTransactionSuccess = do+  address <- originateSimple @MText "test0tzContract" True idContract+  let+    transferData = TransferData+      { tdTo = address+      , tdAmount = 0+      , tdEntrypoint = DefEpName+      , tdParameter = "aaa" :: MText+      }++  transfer transferData
+ test/TestSuite/Cleveland/UsedFramework.hs view
@@ -0,0 +1,34 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.UsedFramework+  ( test_usedFramework+  , test_whenEmulation+  ) where++import Test.Tasty (TestTree, testGroup)++import Test.Cleveland++test_usedFramework :: TestTree+test_usedFramework = testGroup "getRunMode"+  [ testScenarioOnNetwork "On chain" $ scenario do+      getRunMode >>= \case+        NetworkMode -> pass+        EmulationMode -> failure "Returned wrong mode"++  , testScenarioOnEmulator "Emulated" $ scenarioEmulated do+      getRunMode >>= \case+        EmulationMode -> pass+        NetworkMode -> failure "Returned wrong mode"+  ]++test_whenEmulation :: TestTree+test_whenEmulation = testGroup "whenEmulation"+  [ testScenarioOnEmulator "Allows using emulation-only actions within" $ scenario do+      whenEmulation $ setVotingPowers (mkVotingPowers [])++  , testScenarioOnNetwork "Is skipped during on-chain run" $ scenario do+      whenEmulation $ failure "Sad"+  ]
+ test/TestSuite/Cleveland/Util.hs view
@@ -0,0 +1,39 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.Util+  ( test_Time+  ) where++import Data.Fixed (Deci, E0, E1, E12, E3, Milli, Pico, Uni)+import Data.Time (secondsToNominalDiffTime)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Time (ms, sec)++import Test.Cleveland.Util (ceilingUnit, timeToFixed, timeToNominalDiffTime)++test_Time :: TestTree+test_Time =+  testGroup "time-related functions"+    [ testGroup "timeToFixed converts to fixed precision" $+      [ testCase "E0"  $ timeToFixed @E0  (sec 1.234) @?= (1     :: Uni  )+      , testCase "E1"  $ timeToFixed @E1  (sec 1.234) @?= (1.2   :: Deci )+      , testCase "E3"  $ timeToFixed @E3  (sec 1.234) @?= (1.234 :: Milli)+      , testCase "E12" $ timeToFixed @E12 (sec 1.234) @?= (1.234 :: Pico )+      ]+    , testGroup "ceilingUnit rounds up" $+      [ testCase "sec 2.0" $ ceilingUnit (sec 2.0) @?= sec 2+      , testCase "sec 2.1" $ ceilingUnit (sec 2.1) @?= sec 3+      , testCase "sec 2.4" $ ceilingUnit (sec 2.4) @?= sec 3+      , testCase "sec 2.5" $ ceilingUnit (sec 2.5) @?= sec 3+      , testCase "sec 2.9" $ ceilingUnit (sec 2.9) @?= sec 3+      ]+    , testGroup "timeToNominalDiffTime converts to NominalDiffTime" $+      [ testCase "sec 1"   $ timeToNominalDiffTime (sec 1  ) @?= secondsToNominalDiffTime 1+      , testCase "sec 0.1" $ timeToNominalDiffTime (sec 0.1) @?= secondsToNominalDiffTime 0.1+      , testCase "sec 0.9" $ timeToNominalDiffTime (sec 0.9) @?= secondsToNominalDiffTime 0.9+      , testCase "ms 1.2"  $ timeToNominalDiffTime (ms  1.2) @?= secondsToNominalDiffTime 0.0012+      ]+    ]
+ test/TestSuite/Cleveland/VotingPower.hs view
@@ -0,0 +1,40 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module testing voting power instructions and their support from+-- cleveland.+module TestSuite.Cleveland.VotingPower+  ( test_VotingPowers+  ) where++import Test.Tasty++import Lorentz.Value+import Morley.Tezos.Crypto+import Test.Cleveland++test_VotingPowers :: [TestTree]+test_VotingPowers =+  [ testScenario "Can pick voting power of some address" $ scenario do+      contract+        <- originateSimple "vp contract" 0+        =<< importContract @KeyHash @Natural @() ("../../contracts/voting_power.tz")++      let keyHash = unsafeParseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa"+      call contract CallDefault keyHash+      getStorage contract @@== 0++  , testScenarioOnEmulator "Can set voting powers in test scenario" $ scenarioEmulated do+      contract+        <- originateSimple "vp contract" (0, 0)+        =<< importContract @KeyHash @(Natural, Natural) @() ("../../contracts/voting_powers.tz")++      comment "Setting custom voting powers to access them later"+      let keyHash = unsafeParseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa"+      let keyHash2 = unsafeParseKeyHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs"+      setVotingPowers (mkVotingPowers [(keyHash, 123), (keyHash2, 57)])++      call contract CallDefault keyHash+      getStorage contract @@== (123, 180)+  ]
+ test/TestSuite/Cleveland/WithMoneybag.hs view
@@ -0,0 +1,30 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.WithMoneybag+  ( test_withMoneybag+  ) where++import Test.Tasty++import Test.Cleveland++test_withMoneybag :: TestTree+test_withMoneybag =+  testScenario "withMoneybag overrides the funder of new accounts" $ scenario do+    newMoneybag <- newFreshAddress "newMoneybag"+    transferMoney newMoneybag 4_e6++    -- At the end of this test, we want to check that `newAddress` transfers funds from "newMoneybag" to "testAccount".+    -- However, this will only happen if:+    --   1. the "testAccount" alias is not yet known to tezos-client+    --   2. or, it is known, but it has less than 0.5 XTZ.+    -- We use `newFreshAddress` here to ensure "testAccount" is a known alias with 0 XTZ.+    _ <- newFreshAddress "testAccount"++    -- Check that "testAccount" was funded with "newMoneybag"'s tez.+    b0 <- getBalance newMoneybag+    withMoneybag newMoneybag $ newAddress "testAccount"+    b1 <- getBalance newMoneybag+    checkCompares b1 (<) b0
+ test/TestSuite/Cleveland/WithSender.hs view
@@ -0,0 +1,45 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module TestSuite.Cleveland.WithSender+  ( test_Money_are_spent_from_sender+  , test_Sender_in_contract_call_is_updated+  ) where++import Test.Tasty++import Test.Cleveland+import TestSuite.Util (idContract, saveSender)++test_Money_are_spent_from_sender :: TestTree+test_Money_are_spent_from_sender =+  -- Running this on emulator won't work because there+  -- originations and transfers cost nothing+  testScenarioOnNetwork "Money is spent from the sender's address" $ scenario do+    user <- newAddress auto++    balance1 <- getBalance user+    withSender user $ originateSimple @() @() "contract" () idContract+    balance2 <- getBalance user+    checkCompares balance2 (<) balance1++    balance3 <- getBalance user+    withSender user $ inBatch $ originateSimple @() @() "contract" () idContract+    balance4 <- getBalance user+    checkCompares balance4 (<) balance3++test_Sender_in_contract_call_is_updated :: TestTree+test_Sender_in_contract_call_is_updated =+  testScenario "Transfer is made from the sender's address" $ scenario do+    user <- newAddress auto++    contract <- originateSimple "contract" [] saveSender++    withSender user do+      transfer (TransferData contract 0 (ep "") ())+      transferMoney contract 0+      call contract CallDefault ()+      inBatch $ call contract CallDefault ()++    getStorage contract @@== replicate 4 user
+ test/TestSuite/Util.hs view
@@ -0,0 +1,174 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- Utility functions used in the @cleveland:test:cleveland-test@ test suite.+module TestSuite.Util+  ( runPropertyViaTasty+  , runViaTastyOnEmulator+  , runViaTastyOnNetwork+  , outcomeIsFailure+  , shouldFailWithMessage++  -- * Contracts+  , idContract+  , saveInStorageContract+  , saveSender++  -- * Misc+  , BigMapInStorage(..)+  ) where++import Lorentz++import Data.List (isInfixOf)+import Fmt (Buildable, GenericBuildable(..), build, indentF, unlinesF)+import Hedgehog (Property)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase)+import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.Options (OptionSet, singleOption)+import Test.Tasty.Providers (IsTest(run), TestName)+import Test.Tasty.Runners+  (FailureReason(TestFailed), Outcome(Failure, Success), Result(resultOutcome),+  TestTree(AskOptions, SingleTest))++import Test.Cleveland (ClevelandT, EmulatedT, MonadCleveland, attempt, failure)+import Test.Cleveland.Internal.Client (ClientM)+import Test.Cleveland.Internal.Pure (PureM)+import Test.Cleveland.Internal.Scenario+import Test.Cleveland.Tasty.Internal+  (RunOnEmulator(RunOnEmulator), RunOnNetwork(RunOnNetwork), whenNetworkEnabled)+import Test.Cleveland.Tasty.Internal.Options (ContextLinesOpt(ContextLinesOpt))++-- | Runs a cleveland action via Tasty, and performs some checks on the Tasty result.+--+-- It uses the Tasty options taken from the environment (CLI and environment variables).+-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture+-- source code lines not actually related to the test.+--+-- These options can be overriden by passing in an additional 'OptionSet'.+runViaTastyOnEmulator :: TestName -> OptionSet -> EmulatedT PureM () -> (Result -> Assertion) -> TestTree+runViaTastyOnEmulator testName options clevelandTest checkResult =+  AskOptions $ \envOptions ->+    testCase testName $ do+      let allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options+      let tastyTest = RunOnEmulator (scenarioEmulated clevelandTest)+      tastyResult <- run allOptions tastyTest (\_ -> pure ())+      checkResult tastyResult++-- | Runs a cleveland action via Tasty, and performs some checks on the Tasty result.+--+-- It uses the Tasty options taken from the environment (CLI and environment variables).+-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture+-- source code lines not actually related to the test.+--+-- These options can be overriden by passing in an additional 'OptionSet'.+runViaTastyOnNetwork :: TestName -> OptionSet -> ClevelandT ClientM () -> (Result -> Assertion) -> TestTree+runViaTastyOnNetwork testName options clevelandTest checkResult =+  whenNetworkEnabled $ \_ ->+    AskOptions $ \envOptions ->+      testCase testName $ do+        let allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options+        let tastyTest = RunOnNetwork (scenario clevelandTest)+        tastyResult <- run allOptions tastyTest (\_ -> pure ())+        checkResult tastyResult++-- | Runs a cleveland property test via Tasy, and performs some checks on the Tasty result.+--+-- It uses the Tasty options taken from the environment (CLI and environment variables).+-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture+-- source code lines not actually related to the test.+--+-- These options can be overriden by passing in an additional 'OptionSet'.+runPropertyViaTasty :: TestName -> OptionSet -> Property -> (Result -> Assertion) -> TestTree+runPropertyViaTasty testName options prop checkResult =+  AskOptions $ \envOptions ->+    testCase testName $ do+      let+        allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options+        testTree = testProperty "" prop+      tastyResult <- case testTree of+        SingleTest _ test ->+          bracket saveEnv restoreEnv $ \_ -> (run allOptions test (\_ -> pure ()))+        _ -> error "impossible"+      checkResult tastyResult+  where+    saveEnv    = lookupEnv "TERM" <* setEnv "TERM" "dumb"+    restoreEnv = maybe (unsetEnv "TERM") (setEnv "TERM")++-- | Checks that a Tasty test failed because the nested cleveland test failed+-- (and not because, for example, the test framework threw an exception).+outcomeIsFailure :: HasCallStack => Result -> Assertion+outcomeIsFailure tastyResult =+  case resultOutcome tastyResult of+    Failure TestFailed -> pass+    Failure reason ->+      assertFailure $ toString $ unlines+        [ "Expected Tasty test to fail because the cleveland test failed, but failed because:"+        , show reason+        ]+    Success ->+      assertFailure "Expected Tasty test to fail, but it succeeded"++-- | Check that a Cleveland test fails and that the error message contains+-- the given string.+shouldFailWithMessage+  :: forall any caps m.+     (HasCallStack, MonadCleveland caps m, Show any)+  => String -> m any -> m ()+shouldFailWithMessage expectedMessage action  = do+  attempt @SomeException action >>= \case+    Right x ->+      failure $ "Expected action to fail, but it succeeded with: " <> show x+    Left ex ->+      unless (expectedMessage `isInfixOf` displayException ex) $+        failure $ unlinesF+          [ "━━━━━ Expected error message to contain:"+          , indentF 2 $ build expectedMessage+          , ""+          , "━━━━━ Actual error message was:"+          , indentF 2 $ build $ displayException ex+          ]++----------------------------------------------------------------------------+-- Test contracts+----------------------------------------------------------------------------++-- | Simple contract that does nothing when called.+idContractData :: (NiceParameterFull cp, NiceStorage st) => ContractData cp st ()+idContractData = defaultContractData $+  cdr #+  nil @Operation #+  pair++-- | Simple contract that does nothing when called.+idContract :: (NiceParameterFull cp, NiceStorage st) => Contract cp st ()+idContract = compileLorentzContract idContractData++-- | Simple contract that takes a parameter and saves it in its storage.+saveInStorageContract :: (NiceParameterFull st, NiceStorage st) => Contract st st ()+saveInStorageContract = defaultContract $+  car #+  nil @Operation #+  pair++-- | Simple contract that stores the sender's address in its storage.+saveSender :: Contract () [Address] ()+saveSender = defaultContract $+  cdr # sender # cons # nil @Operation # pair+++----------------------------------------------------------------------------+-- Misc+----------------------------------------------------------------------------++-- | Storage for the @big_map_in_storage.tz@ contract.+-- It is placed in this module to work around the GHC stage restriction.+data BigMapInStorage = BigMapInStorage+  { ssField1 :: BigMap Integer Integer+  , ssField2 :: Natural+  }+  deriving stock (Generic, Show, Eq)+  deriving anyclass (IsoValue, HasAnnotation)+  deriving Buildable via GenericBuildable BigMapInStorage
+ test/Tree.hs view
@@ -0,0 +1,5 @@+-- 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 #-}
+ test/fixtures/addrValue.txt view
@@ -0,0 +1,1 @@+"tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp"
+ test/fixtures/addrValue.txt.license view
@@ -0,0 +1,3 @@+SPDX-FileCopyrightText: 2021 Tocqueville Group++SPDX-License-Identifier: LicenseRef-MIT-TQ
+ test/fixtures/intValue.txt view
@@ -0,0 +1,1 @@+42
+ test/fixtures/intValue.txt.license view
@@ -0,0 +1,3 @@+SPDX-FileCopyrightText: 2021 Tocqueville Group++SPDX-License-Identifier: LicenseRef-MIT-TQ