cleveland 0.1.0 → 0.1.1

raw patch · 204 files changed

+4946/−2094 lines, 204 filesdep +temporaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: temporary

API changes (from Hackage documentation)

Files

• CHANGES.md +48/−0
• LICENSE +3/−1
• cleveland.cabal +43/−15
• lorentz-test/Main.hs +2/−3
• lorentz-test/Test/Doc.hs +10/−7
• lorentz-test/Test/DocTest.hs +3/−4
• lorentz-test/Test/Lorentz/BLS12381.hs +3/−4
• lorentz-test/Test/Lorentz/Base.hs +2/−3
• lorentz-test/Test/Lorentz/Case.hs +3/−4
• lorentz-test/Test/Lorentz/Conditionals.hs +2/−3
• lorentz-test/Test/Lorentz/ContractRegistry.hs +4/−5
• lorentz-test/Test/Lorentz/CustomArith.hs +4/−5
• lorentz-test/Test/Lorentz/CustomValue.hs +25/−3
• lorentz-test/Test/Lorentz/DeadCode.hs +4/−5
• lorentz-test/Test/Lorentz/Doc/Positions.hs +2/−3
• lorentz-test/Test/Lorentz/DupableScan.hs +97/−0
• lorentz-test/Test/Lorentz/Entrypoints.hs +19/−20
• lorentz-test/Test/Lorentz/Entrypoints/Doc.hs +8/−9
• lorentz-test/Test/Lorentz/Errors.hs +4/−5
• lorentz-test/Test/Lorentz/Errors/Numeric.hs +3/−4
• lorentz-test/Test/Lorentz/Expr.hs +2/−3
• lorentz-test/Test/Lorentz/Extensible.hs +2/−3
• lorentz-test/Test/Lorentz/Instr/MapOption.hs +46/−0
• lorentz-test/Test/Lorentz/Interpreter.hs +13/−10
• lorentz-test/Test/Lorentz/Macro.hs +420/−6
• lorentz-test/Test/Lorentz/MorleyLogs.hs +22/−15
• lorentz-test/Test/Lorentz/Optimizer.hs +3/−4
• lorentz-test/Test/Lorentz/Pack.hs +7/−7
• lorentz-test/Test/Lorentz/Print.hs +50/−10
• lorentz-test/Test/Lorentz/Product.hs +94/−0
• lorentz-test/Test/Lorentz/ReferencedByName.hs +2/−3
• lorentz-test/Test/Lorentz/Storage.hs +6/−7
• lorentz-test/Test/Lorentz/StoreClass/ComplexRefs.hs +6/−8
• lorentz-test/Test/Lorentz/StoreClass/SetSubmap.hs +5/−7
• lorentz-test/Test/Lorentz/StoreClass/StorageEntrypoints.hs +3/−4
• lorentz-test/Test/Lorentz/StoreClass/SubmapZoom.hs +5/−7
• lorentz-test/Test/Lorentz/Tickets.hs +2/−3
• lorentz-test/Test/Lorentz/Tickets/Contracts.hs +3/−4
• lorentz-test/Test/Lorentz/Tickets/Helpers.hs +5/−4
• lorentz-test/Test/Lorentz/Timelock.hs +4/−5
• lorentz-test/Test/Lorentz/UParam.hs +5/−5
• lorentz-test/Test/Lorentz/Views.hs +2/−3
• lorentz-test/Test/Lorentz/ViewsImport.hs +8/−7
• lorentz-test/Test/Tasty/TypeSpec.hs +6/−5
• lorentz-test/Test/Util/Annotation.hs +4/−3
• lorentz-test/Test/Util/TypeSpec.hs +3/−4
• morley-bench/Main.hs +4/−5
• morley-client-test/Main.hs +2/−3
• morley-client-test/Test/Fee.hs +46/−12
• morley-client-test/Test/RPCKeyRevealing.hs +67/−0
• morley-test/Main.hs +2/−3
• morley-test/Test/Analyzer.hs +4/−5
• morley-test/Test/AsRPC.hs +647/−0
• morley-test/Test/Doc/Position.hs +2/−3
• morley-test/Test/Entrypoints.hs +18/−19
• morley-test/Test/Ext.hs +59/−19
• morley-test/Test/Import.hs +3/−4
• morley-test/Test/Integrational.hs +2/−3
• morley-test/Test/Interpreter.hs +24/−31
• morley-test/Test/Interpreter/Annotations.hs +66/−87
• morley-test/Test/Interpreter/Apply.hs +5/−10
• morley-test/Test/Interpreter/Auction.hs +8/−11
• morley-test/Test/Interpreter/Balance.hs +10/−11
• morley-test/Test/Interpreter/CallSelf.hs +5/−6
• morley-test/Test/Interpreter/CallSelfAddress.hs +2/−3
• morley-test/Test/Interpreter/ComparableSet.hs +4/−5
• morley-test/Test/Interpreter/Compare.hs +7/−9
• morley-test/Test/Interpreter/ComparePairs.hs +5/−6
• morley-test/Test/Interpreter/Conditionals.hs +4/−5
• morley-test/Test/Interpreter/ContractOp.hs +4/−4
• morley-test/Test/Interpreter/CreateAndReverseOps.hs +3/−4
• morley-test/Test/Interpreter/CreateAndTransfer.hs +3/−4
• morley-test/Test/Interpreter/EnvironmentSpec.hs +9/−10
• morley-test/Test/Interpreter/Print.hs +3/−4
• morley-test/Test/Interpreter/Reference.hs +24/−32
• morley-test/Test/Interpreter/SetDelegate.hs +2/−3
• morley-test/Test/Interpreter/StackRef.hs +2/−3
• morley-test/Test/Interpreter/StringCaller.hs +2/−3
• morley-test/Test/Interpreter/TransferAndCreate.hs +3/−4
• morley-test/Test/Interpreter/Views.hs +3/−4
• morley-test/Test/Macro.hs +8/−9
• morley-test/Test/Michelson/Parser/Value.hs +3/−4
• morley-test/Test/Michelson/Runtime.hs +5/−7
• morley-test/Test/Michelson/Show.hs +102/−0
• morley-test/Test/Michelson/Text.hs +8/−9
• morley-test/Test/Michelson/Typed/AnnotatedValue.hs +38/−20
• morley-test/Test/Michelson/Typed/Convert.hs +33/−7
• morley-test/Test/Michelson/Typed/Util.hs +46/−9
• morley-test/Test/Michelson/Typed/Value.hs +2/−3
• morley-test/Test/Morley/Expression.hs +22/−21
• morley-test/Test/OpSize.hs +11/−12
• morley-test/Test/Optimizer.hs +9/−7
• morley-test/Test/Parser.hs +475/−297
• morley-test/Test/Preprocess.hs +5/−5
• morley-test/Test/Printer/Michelson.hs +12/−9
• morley-test/Test/Serialization/Aeson.hs +2/−3
• morley-test/Test/Serialization/Typed/Michelson.hs +25/−27
• morley-test/Test/Serialization/Untyped/Michelson.hs +24/−11
• morley-test/Test/Serialization/Util.hs +5/−6
• morley-test/Test/Tezos/Address.hs +12/−20
• morley-test/Test/Tezos/Core.hs +2/−3
• morley-test/Test/Tezos/Crypto.hs +26/−26
• morley-test/Test/Tezos/Crypto/BLS12381.hs +29/−30
• morley-test/Test/Tezos/Crypto/Hash.hs +2/−3
• morley-test/Test/Tezos/Crypto/Timelock.hs +4/−5
• morley-test/Test/Typeable.hs +2/−3
• morley-test/Test/Typecheck.hs +44/−29
• morley-test/Test/Typecheck/Annotation.hs +5/−6
• morley-test/Test/Untyped/Instr.hs +2/−3
• morley-test/Test/Util/Hedgehog.hs +7/−6
• morley-test/Test/Util/Parser.hs +4/−5
• morley-test/Test/Util/TH.hs +78/−0
• morley-test/Test/ValConversion.hs +4/−5
• morley-test/Test/Views.hs +9/−12
• src/Hedgehog/Gen/Michelson.hs +6/−7
• src/Hedgehog/Gen/Michelson/Typed.hs +11/−11
• src/Hedgehog/Gen/Michelson/Untyped.hs +10/−7
• src/Hedgehog/Gen/Morley/Micheline.hs +4/−5
• src/Hedgehog/Gen/SizedList.hs +25/−0
• src/Hedgehog/Gen/Tezos/Address.hs +4/−5
• src/Hedgehog/Gen/Tezos/Core.hs +7/−8
• src/Hedgehog/Gen/Tezos/Crypto.hs +7/−8
• src/Hedgehog/Gen/Tezos/Crypto/BLS12381.hs +3/−4
• src/Hedgehog/Gen/Tezos/Crypto/Ed25519.hs +4/−5
• src/Hedgehog/Gen/Tezos/Crypto/P256.hs +4/−5
• src/Hedgehog/Gen/Tezos/Crypto/Secp256k1.hs +4/−5
• src/Hedgehog/Gen/Tezos/Crypto/Timelock.hs +5/−6
• src/Lorentz/Test/DupableScan.hs +116/−0
• src/Test/Cleveland.hs +19/−13
• src/Test/Cleveland/Doc.hs +2/−3
• src/Test/Cleveland/Doc/Common.hs +4/−5
• src/Test/Cleveland/Doc/Lorentz.hs +4/−5
• src/Test/Cleveland/Doc/Michelson.hs +4/−5
• src/Test/Cleveland/Ingredients.hs +2/−3
• src/Test/Cleveland/Instances.hs +51/−16
• src/Test/Cleveland/Internal/Abstract.hs +67/−50
• src/Test/Cleveland/Internal/Actions.hs +130/−60
• src/Test/Cleveland/Internal/Client.hs +92/−44
• src/Test/Cleveland/Internal/Exceptions.hs +2/−3
• src/Test/Cleveland/Internal/Hedgehog.hs +4/−5
• src/Test/Cleveland/Internal/Pure.hs +153/−105
• src/Test/Cleveland/Internal/Scenario.hs +3/−4
• src/Test/Cleveland/Lorentz.hs +3/−4
• src/Test/Cleveland/Lorentz/Consumer.hs +3/−4
• src/Test/Cleveland/Lorentz/Entrypoints.hs +4/−4
• src/Test/Cleveland/Lorentz/Import.hs +33/−14
• src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs +10/−8
• src/Test/Cleveland/Lorentz/Requester.hs +3/−4
• src/Test/Cleveland/Lorentz/Ticketer.hs +2/−3
• src/Test/Cleveland/Lorentz/Types.hs +4/−5
• src/Test/Cleveland/Michelson.hs +2/−3
• src/Test/Cleveland/Michelson/Dummy.hs +2/−3
• src/Test/Cleveland/Michelson/Entrypoints.hs +3/−4
• src/Test/Cleveland/Michelson/Import.hs +35/−8
• src/Test/Cleveland/Michelson/Internal/Entrypoints.hs +19/−34
• src/Test/Cleveland/Michelson/Unit.hs +3/−4
• src/Test/Cleveland/Tasty.hs +2/−3
• src/Test/Cleveland/Tasty/Internal.hs +5/−6
• src/Test/Cleveland/Tasty/Internal/Options.hs +4/−5
• src/Test/Cleveland/Tasty/Internal/Report.hs +5/−6
• src/Test/Cleveland/Util.hs +38/−41
• test-common/Test/Util/Contracts.hs +2/−3
• test/Main.hs +2/−3
• test/TestSuite/Cleveland/AddressRevealing.hs +3/−4
• test/TestSuite/Cleveland/Assertions.hs +4/−5
• test/TestSuite/Cleveland/BalanceCheck.hs +6/−6
• test/TestSuite/Cleveland/BatchOperation.hs +12/−10
• test/TestSuite/Cleveland/BatchTransferCheck.hs +9/−10
• test/TestSuite/Cleveland/BlockIntervalGetter.hs +3/−4
• test/TestSuite/Cleveland/BytesSigning.hs +6/−7
• test/TestSuite/Cleveland/CallStack.hs +63/−23
• test/TestSuite/Cleveland/ChainIdGet.hs +4/−5
• test/TestSuite/Cleveland/ContractAllocation.hs +3/−4
• test/TestSuite/Cleveland/DFS.hs +7/−8
• test/TestSuite/Cleveland/Emulated.hs +4/−5
• test/TestSuite/Cleveland/Entrypoints.hs +6/−7
• test/TestSuite/Cleveland/ExpectFailure.hs +9/−10
• test/TestSuite/Cleveland/FailureLogs.hs +3/−4
• test/TestSuite/Cleveland/Import.hs +3/−4
• test/TestSuite/Cleveland/InitialState.hs +2/−3
• test/TestSuite/Cleveland/Level.hs +23/−25
• test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs +2/−3
• test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +51/−19
• test/TestSuite/Cleveland/MismatchError.hs +114/−0
• test/TestSuite/Cleveland/NewAddressCheck.hs +7/−8
• test/TestSuite/Cleveland/OperationReplay.hs +3/−4
• test/TestSuite/Cleveland/PrefixNetworkScenario.hs +19/−11
• test/TestSuite/Cleveland/PrettyFailWith.hs +2/−3
• test/TestSuite/Cleveland/PublicKeyToAddress.hs +5/−6
• test/TestSuite/Cleveland/RefillableAddress.hs +12/−10
• test/TestSuite/Cleveland/RunCode.hs +280/−0
• test/TestSuite/Cleveland/StorageCheck.hs +7/−9
• test/TestSuite/Cleveland/StorageWithBigMaps.hs +113/−6
• test/TestSuite/Cleveland/Tasty.hs +4/−5
• test/TestSuite/Cleveland/Tasty/Report.hs +5/−6
• test/TestSuite/Cleveland/Tasty/Report/Examples.hs +44/−43
• test/TestSuite/Cleveland/Time.hs +5/−6
• test/TestSuite/Cleveland/TransferCheck.hs +4/−5
• test/TestSuite/Cleveland/UsedFramework.hs +8/−10
• test/TestSuite/Cleveland/Util.hs +2/−3
• test/TestSuite/Cleveland/VotingPower.hs +6/−7
• test/TestSuite/Cleveland/WithMoneybag.hs +3/−4
• test/TestSuite/Cleveland/WithSender.hs +3/−4
• test/TestSuite/Util.hs +10/−15

@@ -1,6 +1,54 @@ <!-- Unreleased: append new entries here -->  +0.1.1+=====+* [!1113](https://gitlab.com/morley-framework/morley/-/merge_requests/1113)+  Remove uses of `Parser LetEnv` due to redundant constraint.+* [!1094](https://gitlab.com/morley-framework/morley/-/merge_requests/1094)+  Deprecate morley language extensions+  + Functions for importing and testing Morley contracts are added: `Test.Cleveland.Michelson.Import.testTreesWithUntypedContractExt`, `Test.Cleveland.Michelson.Import.testTreesWithTypedContractExt`, `Test.Cleveland.Lorentz.Import.importContractExt`. All these functions are considered deprecated.+* [!965](https://gitlab.com/morley-framework/morley/-/merge_requests/965)+  Use Morley's fixed-size lists+  + Add Hedgehog generators for sized lists.+  + Introduce `enumAliasHints` for generating a sized list of similarly named alias hints.+* [!1072](https://gitlab.com/morley-framework/morley/-/merge_requests/1072)+  Add `runCode` to Cleveland+* [!1070](https://gitlab.com/morley-framework/morley/-/merge_requests/1070)+  Simplify cleveland's internals & public api+  + Relaced the `NiceUnpackedValue (AsRPC st)` constraint in `getStorage`+  + Removed the `NicePackedValue k` constraint from `getAllBigMapValuesMaybe`,+    `getAllBigMapValues`, `getBigMapSizeMaybe`, and `getBigMapSize`.+* [!1025](https://gitlab.com/morley-framework/morley/-/merge_requests/1025)+  Reduce the number of unsafe functions at the call site+  + Remove `unsafeFromHex` converter that is used as counter-part of safe `fromHex` and replaced with `unsafe . fromHex`.+  + Refactor `fromHex` to return `Either` instead of `Maybe`.+  + Add `parseAddressFromHex` helper to get rid of duplicated usages of `parseAddressRaw . unsafe . fromHex`.+* [!978](https://gitlab.com/morley-framework/morley/-/merge_requests/978)+  Make it difficult to misuse 'Show'+  + Use `Buildable` and `pretty` preferrentially.+  + Add `Buildable` instances for `FaluireReason`, `Either a b`.+  + Add `PrettyShow` instances for `TypeSpec` (in lorentz-test) and `Time _` (in cleveland itself)./+  + Avoid using `(+||)` and `(||+)`.+  + Use `Debug.show` when defining `Show` instances.+* [!1058](https://gitlab.com/morley-framework/morley/-/merge_requests/1058)+  Add `Buildable` instances for Unit, tuples up to 8 elements & bytestrings+* [!1057](https://gitlab.com/morley-framework/morley/-/merge_requests/1057)+  Test `Show` and `RenderDoc` instances of `Annotation t`, `AnnotationSet`, `Notes t`, `InstrAbstract op`+* [!997](https://gitlab.com/morley-framework/morley/-/merge_requests/997)+  Check necessity in initial `cast` automatically in Lorentz contracts+* [!1044](https://gitlab.com/morley-framework/morley/-/merge_requests/1044)+  Fix `getRunMode` and `whenEmulated`+  + `getRunMode` is replaced by `ifEmulation` helper.+  + A new helper `whenNetwork` is added.+  + One caveat is that functions passed to `ifEmulation` are universally quantified over the outer monad, so if additional constraints are required beyond `MonadCleveland` or `MonadEmulated`, those constraints have to go on the base monad, e.g. `(MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m ()`.+ifEmulation.+* [!1043](https://gitlab.com/morley-framework/morley/-/merge_requests/1043)+  Extract actual + expected pattern into a datatype and show diff in type mismatch+* [!1037](https://gitlab.com/morley-framework/morley/-/merge_requests/1037)+  Add synonyms for `SomeConstrainedValue`+  + Reimplement `SomeConstant`, `SomeValue`, `SomeStorage` via `SomeConstrainedValue`.+ 0.1.0 ===== Initial release extracted from the [morley](https://hackage.haskell.org/package/morley)

@@ -1,4 +1,6 @@-MIT License Copyright (c) 2020 Tocqueville Group+MIT License+Copyright (c) 2021-2022 Oxhead Alpha+Copyright (c) 2019-2021 Tocqueville Group  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           cleveland-version:        0.1.0+version:        0.1.1 synopsis:       Testing framework for Morley. description:    This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz. These tests can be run on an emulated environment or on a real network. category:       Blockchain@@ -13,7 +13,7 @@ bug-reports:    https://gitlab.com/morley-framework/morley/-/issues author:         Serokell, Tocqueville Group maintainer:     Serokell <hi@serokell.io>-copyright:      2020 Tocqueville Group+copyright:      2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license:        MIT license-file:   LICENSE build-type:     Simple@@ -36,6 +36,7 @@       Hedgehog.Gen.Michelson.Typed       Hedgehog.Gen.Michelson.Untyped       Hedgehog.Gen.Morley.Micheline+      Hedgehog.Gen.SizedList       Hedgehog.Gen.Tezos.Address       Hedgehog.Gen.Tezos.Core       Hedgehog.Gen.Tezos.Crypto@@ -44,6 +45,7 @@       Hedgehog.Gen.Tezos.Crypto.P256       Hedgehog.Gen.Tezos.Crypto.Secp256k1       Hedgehog.Gen.Tezos.Crypto.Timelock+      Lorentz.Test.DupableScan       Test.Cleveland       Test.Cleveland.Doc       Test.Cleveland.Doc.Common@@ -104,24 +106,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections@@ -137,6 +141,7 @@     , MonadRandom     , aeson     , base-noprelude >=4.7 && <5+    , bytestring     , constraints >=0.11     , containers     , criterion@@ -199,12 +204,14 @@       TestSuite.Cleveland.Level       TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator       TestSuite.Cleveland.Lorentz.Entrypoints+      TestSuite.Cleveland.MismatchError       TestSuite.Cleveland.NewAddressCheck       TestSuite.Cleveland.OperationReplay       TestSuite.Cleveland.PrefixNetworkScenario       TestSuite.Cleveland.PrettyFailWith       TestSuite.Cleveland.PublicKeyToAddress       TestSuite.Cleveland.RefillableAddress+      TestSuite.Cleveland.RunCode       TestSuite.Cleveland.StorageCheck       TestSuite.Cleveland.StorageWithBigMaps       TestSuite.Cleveland.Tasty@@ -245,24 +252,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections@@ -295,6 +304,7 @@     , tasty     , tasty-hedgehog     , tasty-hunit-compat+    , temporary     , text     , time   default-language: Haskell2010@@ -314,18 +324,21 @@       Test.Lorentz.CustomValue       Test.Lorentz.DeadCode       Test.Lorentz.Doc.Positions+      Test.Lorentz.DupableScan       Test.Lorentz.Entrypoints       Test.Lorentz.Entrypoints.Doc       Test.Lorentz.Errors       Test.Lorentz.Errors.Numeric       Test.Lorentz.Expr       Test.Lorentz.Extensible+      Test.Lorentz.Instr.MapOption       Test.Lorentz.Interpreter       Test.Lorentz.Macro       Test.Lorentz.MorleyLogs       Test.Lorentz.Optimizer       Test.Lorentz.Pack       Test.Lorentz.Print+      Test.Lorentz.Product       Test.Lorentz.ReferencedByName       Test.Lorentz.Storage       Test.Lorentz.StoreClass.ComplexRefs@@ -369,24 +382,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections@@ -431,6 +446,7 @@   main-is: Main.hs   other-modules:       Test.Fee+      Test.RPCKeyRevealing       Tree       Test.Util.Contracts       Paths_cleveland@@ -458,24 +474,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections@@ -489,8 +507,10 @@   build-tool-depends:       tasty-discover:tasty-discover   build-depends:-      base-noprelude >=4.7 && <5+      HUnit+    , base-noprelude >=4.7 && <5     , cleveland+    , cryptonite     , directory     , filepath     , morley@@ -505,6 +525,7 @@   main-is: Main.hs   other-modules:       Test.Analyzer+      Test.AsRPC       Test.Doc.Position       Test.Entrypoints       Test.Ext@@ -535,6 +556,7 @@       Test.Macro       Test.Michelson.Parser.Value       Test.Michelson.Runtime+      Test.Michelson.Show       Test.Michelson.Text       Test.Michelson.Typed.AnnotatedValue       Test.Michelson.Typed.Convert@@ -563,6 +585,7 @@       Test.Util.Hedgehog       Test.Util.HUnit       Test.Util.Parser+      Test.Util.TH       Test.ValConversion       Test.Views       Tree@@ -592,24 +615,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections@@ -655,6 +680,7 @@     , tasty-hedgehog     , tasty-hspec     , tasty-hunit-compat+    , template-haskell     , text     , unordered-containers     , vinyl@@ -689,24 +715,26 @@       FlexibleInstances       GADTs       GeneralizedNewtypeDeriving+      ImportQualifiedPost       LambdaCase       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns       NegativeLiterals-      NumericUnderscores       NumDecimals+      NumericUnderscores       OverloadedLabels       OverloadedStrings       PatternSynonyms       PolyKinds-      QuasiQuotes       QuantifiedConstraints+      QuasiQuotes       RankNTypes       RecordWildCards       RecursiveDo       ScopedTypeVariables       StandaloneDeriving+      StandaloneKindSignatures       StrictData       TemplateHaskell       TupleSections

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Main   ( main

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on automatic documentation generation. @@ -11,7 +10,8 @@   , test_fakeCoerce   ) where -import qualified Data.Set as Set+import Data.Set qualified as Set+import Data.Text.Lazy.Builder (toLazyText) import Fmt (build) import Hedgehog (evalNF, property) import Test.HUnit (assertBool, assertFailure, (@?=))@@ -20,9 +20,10 @@ import Test.Tasty.Hedgehog (testProperty)  import Lorentz ((#))-import qualified Lorentz as L+import Lorentz qualified as L import Morley.Michelson.Doc import Morley.Michelson.Typed+import Morley.Util.Markdown import Morley.Util.Named import Test.Cleveland.Doc.Lorentz @@ -79,8 +80,10 @@                case lookupDocBlockSection subcontents of                  Just (DDescription "a" :| []) ->                    pass-                 _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents-            _ -> assertFailure $ "Unexpected contents: " <> show contents+                 _ -> assertFailure $ toString $ toLazyText $+                        "Unexpected subcontents: " <> docBlockToMarkdown (HeaderLevel 1) subcontents+            _ -> assertFailure $ toString $ toLazyText $+                  "Unexpected contents: " <> docBlockToMarkdown (HeaderLevel 1) contents   ]  -- Test on loops on dependency graph of doc items

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on doc test framework. module Test.DocTest@@ -13,7 +12,7 @@ import Test.Tasty.HUnit (testCase)  import Lorentz ((#), (/->))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Entrypoints.Doc import Morley.Michelson.Doc import Test.Cleveland.Doc

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}@@ -14,7 +13,7 @@  import Test.HUnit (Assertion, (@?=)) -import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Morley.Tezos.Crypto.BLS12381 qualified as BLS  pairingCheckCode :: Lambda (Bls12381G1, Bls12381G2) Bool pairingCheckCode = do

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for basic Lorentz functionality. 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on mere @case@ in Lorentz (without entrypoints). module Test.Lorentz.Case@@ -13,7 +12,7 @@ import Test.Tasty.HUnit (testCase)  import Lorentz ((#), (/->))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Run.Simple import Morley.Michelson.Typed (IsoValue) 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -13,7 +12,7 @@ import Lorentz import Prelude hiding (drop) -import qualified Data.Map as Map+import Data.Map qualified as Map import System.Directory (removeFile) import System.Directory.Internal.Prelude (isDoesNotExistError) import Test.HUnit (Assertion, assertFailure)@@ -50,7 +49,7 @@ checkAndRemoveFile file =   removeFile file `catch` \e ->     if isDoesNotExistError e-    then assertFailure $ "File " <> show file <> " was not created"+    then assertFailure $ "File \"" <> file <> "\" was not created"     else throwM e  unit_contractRegistryCommands :: Assertion

@@ -1,8 +1,7 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA --- | Note: This extension is enabled because it allows better representation of tests+-- Note: This extension is enabled because it allows better representation of tests -- with @BinBase@. These tests require special representation behavior because 'show' works -- incorrect with non-decimal base. {-# LANGUAGE HexFloatLiterals #-}@@ -14,7 +13,7 @@   ) where  import Prelude hiding (div)-import Test.Tasty+import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))  import Lorentz

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Checks that the strategies for 'Morley.Util.CustomGeneric' work as expected to -- produce 'IsoValue' with a custom shape.@@ -15,6 +14,7 @@ import GHC.TypeNats (type (-)) import Test.Tasty (TestTree) +import Lorentz.Layouts.NonDupable import Lorentz.Value import Morley.Michelson.Typed.T @@ -157,6 +157,20 @@  deriving anyclass instance IsoValue a => IsoValue (NewType a) +data SemiDupableType = SemiDupableType+  { _sdt1 :: Integer+  , _sdt2 :: Natural+  , _sdt3 :: ByteString+  , _sdt4 :: MText+  , _sdt5 :: ()+  , _sdt6 :: Ticket Integer+  , _sdt7 :: Ticket Natural+  }++$(deriveSemiDupableGeneric "SemiDupableType" 2)++deriving anyclass instance IsoValue SemiDupableType+ ---------------------------------------------------------------------------- -- Expected resulting IsoValue ----------------------------------------------------------------------------@@ -213,6 +227,11 @@ type ExpectedLigoCombSumValue =   'TOr 'TInt 'TUnit +type ExpectedSemiDupableValue =+  'TPair+    ('TPair ('TPair 'TInt 'TNat) ('TPair 'TBytes ('TPair 'TString 'TUnit)))+    ('TPair ('TTicket 'TInt) ('TTicket 'TNat))+ ---------------------------------------------------------------------------- -- Type equality checking ----------------------------------------------------------------------------@@ -259,3 +278,6 @@  _checkNewType :: ToT (NewType a) :~: ToT (CustomType a) _checkNewType = Refl++_checkSemiDupable :: ToT SemiDupableType :~: ExpectedSemiDupableValue+_checkSemiDupable = Refl

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- TODO [#549]: remove this pragma {-# OPTIONS_GHC -Wno-deprecations #-}@@ -17,11 +16,11 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Base import Lorentz.Run import Morley.Michelson.Typed (Instr(Seq))-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T  test_Test :: [TestTree] test_Test =

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on ordering of documentation items. module Test.Lorentz.Doc.Positions

@@ -0,0 +1,97 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Tests on 'Lorentz.Test.DupableScan' module.+module Test.Lorentz.DupableScan+  ( test_checkDupablesDistribution+  , test_testDupablesDistribution+  ) where++import Data.Constraint (Dict(..))+import Data.Typeable (typeRep)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))++import Lorentz.Layouts+import Lorentz.Test.DupableScan+import Lorentz.Value++data ProperSample = ProperSample+  { _s1a :: Integer+  , _s1b :: MText+  , _s1c :: Ticket ()+  , _s1d :: Ticket Natural+  } deriving stock (Generic)++data MisplacedDupableSample = MisplacedDupableSample+  { _s2a :: Integer+  , _s2b :: MText+  , _s2c :: Natural+  , _s2d :: Ticket Natural+  } deriving stock (Generic)++data MisplacedNonDupableSample = MisplacedNonDupableSample+  { _s3a :: Ticket ByteString+  , _s3b :: MText+  , _s3c :: Ticket ()+  , _s3d :: Ticket Natural+  } deriving stock (Generic)++data CombGenericSample = CombGenericSample+  { _s4a :: Integer+  , _s4b :: Ticket ()+  , _s4c :: Ticket Integer+  , _s4d :: Ticket Natural+  }++customGeneric "CombGenericSample" rightComb++test_checkDupablesDistribution :: [TestTree]+test_checkDupablesDistribution =+  [ testCase "Good type" $+      checkDupablesDistribution @ProperSample @?= Right ()++  , testCase "Misplaced dupable" $+      checkDupablesDistribution @MisplacedDupableSample @?= Left BadElement+        { beExpectedDupability = False+        , beRecName = Just "_s2c"+        , beRecType = typeRep (Proxy @Natural)+        }++  , testCase "Misplaced non-dupable" $+      checkDupablesDistribution @MisplacedNonDupableSample @?= Left BadElement+        { beExpectedDupability = True+        , beRecName = Just "_s3a"+        , beRecType = typeRep (Proxy @(Ticket ByteString))+        }++  , testCase "Comb generic" $+      checkDupablesDistribution @CombGenericSample @?= Right ()++  ]++-- Two ways to test product type layout++test_testDupablesDistribution :: TestTree+test_testDupablesDistribution = testDupablesDistribution @ProperSample++_test_typeVerifyDupablesDistribution :: Dict (VerifyDupablesDistribution ProperSample)+_test_typeVerifyDupablesDistribution = Dict++-- Checking that deriveSemiDupableGeneric matches with our test utilities+----------------------------------------------------------------------------++data MegaType = MegaType+  { _mt1 :: Integer+  , _mt2 :: Natural+  , _mt3 :: ()+  , _mt4 :: MText+  , _mt5 :: ByteString+  , _mt6 :: Ticket Natural+  , _mt7 :: Ticket Integer+  }++deriveSemiDupableGeneric "MegaType" 2++_test_MegaType_layout :: Dict (VerifyDupablesDistribution MegaType)+_test_MegaType_layout = Dict

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. module Test.Lorentz.Entrypoints@@ -21,7 +20,7 @@ import Test.TypeSpec (Is, TypeSpec(..))  import Lorentz ((#), (/->))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Annotation import Lorentz.Constraints import Lorentz.Entrypoints@@ -45,7 +44,7 @@   | Do3 MyEntrypoints2   | Do4 MyParams   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints1a   = Do1a Integer@@ -53,7 +52,7 @@   | Do3a MyEntrypoints2   | Do4a MyParams   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints2   = Do10@@ -65,49 +64,49 @@   = Do12 ("tuplearg" :! ("TL" :! Integer, "TR" :!  Natural), "boolarg" :! Bool)   | Do13 ("integerarg" :! Integer, "boolarg" :! Bool)   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints4   = Do14 ("viewarg1" :! L.View_ ("owner" :! L.Address) Natural)   | Do15 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints5   = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural))   | Do17 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints6   = Do18 ("lambdaarg" :! L.Lambda Natural Natural)   | Do19 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints7   = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)])   | Do21 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints8   = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address)))   | Do23 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints9   = Do24 ("maybearg" :? ("maybeinner" :! Natural))   | Do25 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints10   = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ())   | Do27 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypoints11   = Do28 ("kek" :! Natural, "pek" :! Integer)@@ -119,19 +118,19 @@   = Default Integer   | NonDefault Natural   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypointsWithRoot   = Dor1   | Dor2 Natural   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypointsWithCustomAnn   = Doc1 Natural   | Doc2 CustomProd   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data CustomProd = CustomProd   { cp1 :: Natural@@ -167,7 +166,7 @@   = Dod1   | Dod2 MyEntrypointsSubDelegated   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data MyEntrypointsSubDelegated   = Dosd1@@ -452,10 +451,10 @@   => EntrypointRef mname   -> arg   -> Contract (TAddress cp ()) () ()-callerContract epRef arg = L.defaultContract $+callerContract epRef argument = L.defaultContract $   L.car # L.contractCalling epRef #   L.assertSome ("Contract lookup failed" :: MText) #-  L.push 1 # L.push arg # L.transferTokens #+  L.push 1 # L.push argument # L.transferTokens #   L.dip (L.unit # L.nil) # L.cons # L.pair  test_Contract_call :: [TestTree]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on autodoc for entrypoints. module Test.Lorentz.Entrypoints.Doc@@ -15,7 +14,7 @@ import Test.Tasty.HUnit (testCase)  import Lorentz ((/->), (:->))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Annotation import Lorentz.Doc import Lorentz.Entrypoints@@ -46,7 +45,7 @@   = Do1 Integer   | Do2 MySub   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance TypeHasDoc MyPlainEps where   typeDocMdDescription = "MyPlainEps"@@ -67,7 +66,7 @@   = Dor1 Integer   | Dor2 MySub   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints MyRecursiveEps where   type ParameterEntrypointsDerivation MyRecursiveEps = EpdRecursive@@ -83,7 +82,7 @@   = Dod1 Integer   | Dod2 MyPlainEps   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints MyDelegateEps where   type ParameterEntrypointsDerivation MyDelegateEps = EpdDelegate@@ -106,7 +105,7 @@   = Do0   | Default   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance TypeHasDoc MyDefEps where   typeDocMdDescription = "MyDefEps"@@ -128,7 +127,7 @@   = Dord1 MySub   | Dord2 MyDefEps   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints MyRecursiveDefEps where   type ParameterEntrypointsDerivation MyRecursiveDefEps = EpdRecursive

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-}@@ -14,8 +13,8 @@  import Lorentz as L -import qualified Data.Bimap as Bimap-import qualified Data.HashSet as HS+import Data.Bimap qualified as Bimap+import Data.HashSet qualified as HS import Test.Tasty (TestTree) import Test.Tasty.HUnit (Assertion, (@?=)) 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,7 +12,7 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Base import Lorentz.Doc import Lorentz.Errors

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE NoApplicativeDo, RebindableSyntax #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Lorentz.Extensible   ( test_Extensible

@@ -0,0 +1,46 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Tests for 'map' instruction over 'Maybe' (a.k.a. @option@)+module Test.Lorentz.Instr.MapOption+  ( test_mapOption+  ) where++import Hedgehog (forAll, property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Lorentz+import Prelude hiding (drop, map)+import Test.Tasty.Hedgehog++import Test.Tasty (TestTree)++import Test.Cleveland++exampleMapContract :: Contract (Maybe Integer) Integer ()+exampleMapContract = defaultContract $+  unpair #+  map (add # push @Natural 0) #+  drop #+  nil #+  pair++test_mapOption :: [TestTree]+test_mapOption =+  [ testScenario "MAP over option int" $ scenario do+      handle <- originateSimple "map example contract" 123 exampleMapContract+      call handle CallDefault Nothing+      getStorage handle @@== 123+      call handle CallDefault (Just 321)+      getStorage handle @@== 444+      call handle CallDefault Nothing+      getStorage handle @@== 444+  , testProperty "MAP over option int randomized test" $ property do+      let intGen = Gen.integral (Range.linear -10000 10000)+      st <- forAll intGen+      arg <- forAll $ Gen.maybe intGen+      testScenarioProps $ scenario do+        handle <- originateSimple "map example contract" st exampleMapContract+        call handle CallDefault arg+        getStorage handle @@== (fromMaybe 0 arg + st)+  ]

@@ -1,7 +1,9 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ module Test.Lorentz.Interpreter   ( test_Entry_points_lookup   , test_Entry_points_calling@@ -10,26 +12,27 @@ import System.FilePath ((</>)) import Test.Tasty (TestTree, testGroup) -import Lorentz (EpdPlain, HasAnnotation, ParameterHasEntrypoints(..), toAddress)+import Lorentz (EpdPlain, ParameterHasEntrypoints(..), toAddress) import Morley.Michelson.Text import Morley.Michelson.Typed (IsoValue(..))-import qualified Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Cleveland+import Test.Cleveland.Lorentz.Import (importContractExt) import Test.Cleveland.Michelson (testTreesWithTypedContract)  data Contract1Parameter   = Contract11 Integer   | Contract12 MText   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  data Self1Parameter   = Self11 Integer   | Self12 ()   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints Contract1Parameter where   type ParameterEntrypointsDerivation Contract1Parameter = EpdPlain@@ -121,7 +124,7 @@       call1 <- importContract @Address @_ @() $ dir </> "call1.mtz"       callerRef <- originateSimple "caller" () call1 -      contract1 <- importContract @Contract1Parameter @_ @() $ dir </> "contract1.mtz"+      contract1 <- runIO $ importContractExt @Contract1Parameter @_ @() $ dir </> "contract1.mtz"       targetRef <- originateSimple "target" 0 contract1        transfer TransferData@@ -134,7 +137,7 @@       getStorage @Integer targetRef @@== 5    , testScenario "Calling some entrypoint in SELF" $ scenario do-      self1 <- importContract @Self1Parameter @_ @() $ dir </> "self1.mtz"+      self1 <- runIO $ importContractExt @Self1Parameter @_ @() $ dir </> "self1.mtz"       contractRef <- originateSimple "self" 0 self1        transfer TransferData

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz macros. --@@ -9,21 +8,107 @@ -- type-level numbers)  module Test.Lorentz.Macro-  ( unit_duupX+  ( unit_dropX+  , unit_cloneX+  , unit_duupX+  , unit_framedN+  , unit_pair   , unit_replaceN   , unit_updateN++  , unit_papair+  , unit_ppaiir+  , unit_cdar+  , unit_cddr+  , unit_caar+  , unit_cadr+  , unit_setCar+  , unit_setCdr+  , unit_mapCar+  , unit_mapCdr+  , unit_ifRight+  , unit_ifSome+  , unit_when_+  , unit_unless_+  , unit_whenSome+  , unit_whenNone++  , unit_mapInsert+  , unit_mapInsertNew+  , unit_deleteMap+  , unit_setInsert+  , unit_setInsertNew+  , unit_setDelete++  , unit_addressToEpAddress+  , test_pushContractRef+  , unit_dupTop2+  , unit_fromOption+  , unit_isSome+  , unit_non+  , unit_non'+  , unit_isEmpty+  , unit_nonZero+   , test_execute   , test_applicate   ) where -import Lorentz import Prelude hiding (drop, swap) -import Test.HUnit (Assertion, (@?=))+import Data.Map qualified as M+import Data.Set qualified as S+import Debug qualified (show)++import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) +import Lorentz qualified as L +import Lorentz+import Morley.Tezos.Address (parseAddress)+import Test.Cleveland+  (call, expectFailedWith, originateSimple, scenarioEmulated, testScenarioOnEmulator)++----------------------------------------------------------------------------+-- Macros parameterized with type-level numbers+----------------------------------------------------------------------------++unit_dropX :: Assertion+unit_dropX = do+  dropX @0 @?= dropX0+  dropX @1 @?= dropX1+  dropX @2 @?= dropX2+  dropX @1 @?= dropX1'+  where+    dropX0 :: '[Bool] :-> '[]+    dropX0 = dipN @0 drop++    dropX1 :: [Bool, Integer] :-> '[Bool]+    dropX1 = dipN @1 drop++    dropX2 :: [Bool, Integer, Bool] :-> [Bool, Integer]+    dropX2 = dipN @2 drop++    dropX1' :: [Bool, Integer, Bool] :-> [Bool, Bool]+    dropX1' = dipN @1 drop++unit_cloneX :: Assertion+unit_cloneX = do+  cloneX @0 @?= cloneX0+  cloneX @1 @?= cloneX1+  cloneX @2 @?= cloneX2+  where+    cloneX0 :: [Bool, Integer] :-> [Bool, Integer]+    cloneX0 = nop++    cloneX1 :: [Bool, Integer] :-> [Bool, Bool, Integer]+    cloneX1 = dup # nop++    cloneX2 :: [Bool, Integer] :-> [Bool, Bool, Bool, Integer]+    cloneX2 = dup # dup # nop+ unit_duupX :: Assertion unit_duupX = do   duupX @1 @?= duupX1@@ -39,6 +124,54 @@     duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool]     duupX3 = dupN @3 +unit_framedN :: Assertion+unit_framedN = do+  framedN @0 nop @?= framedN0+  framedN @1 drop @?= framedN1+  framedN @2 cons @?= framedN2+  framedN @3 (eq # L.and) # framedN @2 cons @?= framedNC+  where+    framedN0 :: '[Bool] :-> '[Bool]+    framedN0 = framed @'[Bool] @'[] @'[] nop++    framedN1 :: [Bool, (), Integer] :-> [(), Integer]+    framedN1 = framed @[(), Integer] @'[Bool] @'[] drop++    framedN2 :: [Bool, [Bool]] :-> '[[Bool]]+    framedN2 = framed @'[] @[Bool, [Bool]] @'[[Bool]] cons++    framedNC :: [Integer, Integer, Bool, [Bool], Integer] :-> [[Bool], Integer]+    framedNC =+      framed @[[Bool], Integer] @[Integer, Integer, Bool] @'[Bool] (eq # L.and) #+      framed @'[Integer] @[Bool, [Bool]] @'[[Bool]] cons++unit_pair :: Assertion+unit_pair = do+  carN @0 @?= carN0+  carN @1 @?= carN1+  carN @2 @?= carN2+  cdrN @0 @?= cdrN0+  cdrN @1 @?= cdrN1+  cdrN @2 @?= cdrN2+  where+    carN0 :: '[(Bool, Integer), Integer] :-> '[Bool, Integer]+    carN0 = pairGet @1++    carN1 :: '[(Integer, (Bool, Integer))] :-> '[Bool]+    carN1 = pairGet @3++    carN2 :: [(Integer, (Integer, (Bool, Integer))), Integer] :-> [Bool, Integer]+    carN2 = pairGet @5++    cdrN0 :: '[(Integer, Bool)] :-> '[(Integer, Bool)]+    cdrN0 = pairGet @0++    cdrN1 :: [(Integer, Bool), Integer] :-> [Bool, Integer]+    cdrN1 = pairGet @2++    cdrN2 :: '[(Integer, (Integer, Bool))] :-> '[Bool]+    cdrN2 = pairGet @4+ unit_replaceN :: Assertion unit_replaceN = do   replaceN @1 @?= swap # drop@@ -65,6 +198,287 @@      updateN3 :: [Bool, Integer, (), [Bool]] :-> [Integer, (), [Bool]]     updateN3 = dug @2 # dipN @2 cons++----------------------------------------------------------------------------+-- Other syntactic conveniences macros+----------------------------------------------------------------------------++unit_papair :: Assertion+unit_papair = do+  papair @?= papair'+  where+    papair' :: '[Bool, Integer, ()] :-> '[((Bool, Integer), ())]+    papair' = pair # pair++unit_ppaiir :: Assertion+unit_ppaiir = do+  ppaiir @?= ppaiir'+  where+    ppaiir' :: '[Bool, Integer, ()] :-> '[(Bool, (Integer, ()))]+    ppaiir' = dip pair # pair++unit_cdar :: Assertion+unit_cdar = do+  cdar @?= cdar'+  where+    cdar' :: '[(Bool, (Integer, ()))] :-> '[Integer]+    cdar' = cdr # car++unit_cddr :: Assertion+unit_cddr = do+  cddr @?= cddr'+  where+    cddr' :: '[(Bool, (Integer, ()))] :-> '[()]+    cddr' = cdr # cdr++unit_caar :: Assertion+unit_caar = do+  caar @?= caar'+  where+    caar' :: '[((Bool, Integer), ())] :-> '[Bool]+    caar' = car # car++unit_cadr :: Assertion+unit_cadr = do+  cadr @?= cadr'+  where+    cadr' :: '[((Bool, Integer), ())] :-> '[Integer]+    cadr' = car # cdr++unit_setCar :: Assertion+unit_setCar = do+  setCar @?= setCar'+  where+    setCar' :: '[(Bool, Integer), ()] :-> '[((), Integer)]+    setCar' = cdr # swap # pair++unit_setCdr :: Assertion+unit_setCdr = do+  setCdr @?= setCdr'+  where+    setCdr' :: '[(Bool, Integer), ()] :-> '[(Bool, ())]+    setCdr' = car # pair++unit_mapCar :: Assertion+unit_mapCar = do+  mapCar L.not @?= mapCar'+  where+    mapCar' :: '[(Integer, Bool)] :-> '[(Integer, Bool)]+    mapCar' = unpair # L.not # pair++unit_mapCdr :: Assertion+unit_mapCdr = do+  mapCdr L.not @?= mapCdr'+  where+    mapCdr' :: '[(Bool, Integer)] :-> '[(Bool, Integer)]+    mapCdr' = unpair # dip L.not # pair++unit_ifRight :: Assertion+unit_ifRight = do+  ifRight L.not (dup # L.compare # eq0) @?= ifRight'+  where+    ifRight' :: '[Either Integer Bool] :-> '[Bool]+    ifRight' = ifLeft (dup # L.compare # eq0) L.not++unit_ifSome+  :: Assertion+unit_ifSome = do+  ifSome (dup # L.compare # eq0) (push True) @?= ifSome'+  where+    ifSome' :: '[Maybe Integer] :-> '[Bool]+    ifSome' = ifNone (push True) (dup # L.compare # eq0)++unit_when_ :: Assertion+unit_when_ = do+  when_ (push 5 # add @Integer) @?= when_'+  push 3 # push True # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 8+  push 3 # push False # when_ (push 5 # add @Integer @Integer) -$? () @?= Right 3+  where+    when_' :: '[Bool, Integer] :-> '[Integer]+    when_' = if_ (push 5 # add @Integer) nop++unit_unless_ :: Assertion+unit_unless_ = do+  unless_ (push 5 # add @Integer) @?= unless_'+  push 3 # push True # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 3+  push 3 # push False # unless_ (push 5 # add @Integer @Integer) -$? () @?= Right 8+  where+    unless_' :: '[Bool, Integer] :-> '[Integer]+    unless_' = if_ nop (push 5 # add @Integer)++unit_whenSome :: Assertion+unit_whenSome = do+  whenSome drop @?= whenSome'+  where+    whenSome' :: '[Maybe Integer] :-> '[]+    whenSome' = ifSome drop nop++unit_whenNone :: Assertion+unit_whenNone = do+  whenNone (push True) @?= whenNone'+  where+    whenNone' :: '[Maybe Bool] :-> '[Bool]+    whenNone' = ifNone (push True) nop++unit_mapInsert :: Assertion+unit_mapInsert = do+  mapInsert @?= mapInsert'+  where+    mapInsert' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool]+    mapInsert' = dip L.some # update++unit_mapInsertNew :: Assertion+unit_mapInsertNew = do+  mapInsertNew nop @?= mapInsertNew'+  mapInsertNewValid -$? () @?= Right (M.singleton 5 True)+  let mapInsertFail = mapInsertNewInvalid -$? ()+  assertBool (Debug.show mapInsertFail <> " should fail") $ isLeft mapInsertFail+  where+    mapInsertNew' :: '[Integer, Bool, Map Integer Bool] :-> '[Map Integer Bool]+    mapInsertNew' = dip L.some # dup # dip getAndUpdate # swap # ifNone drop (drop # nop # failWith)++    mapInsertNewValid :: '[] :-> '[Map Integer Bool]+    mapInsertNewValid = emptyMap # push True # push 5 # mapInsertNew nop++    mapInsertNewInvalid :: '[] :-> '[Map Integer Bool]+    mapInsertNewInvalid =+      emptyMap #+      push True # push 5 # mapInsertNew nop #+      push True # push 5 # mapInsertNew nop++unit_deleteMap :: Assertion+unit_deleteMap = do+  deleteMap @?= deleteMap'+  where+    deleteMap' :: '[Integer, Map Integer Bool] :-> '[Map Integer Bool]+    deleteMap' = dip (none @Bool) # update++unit_setInsert :: Assertion+unit_setInsert = do+  setInsert @?= setInsert'+  where+    setInsert' :: '[Integer, Set Integer] :-> '[Set Integer]+    setInsert' = dip (push True) # update++unit_setInsertNew :: Assertion+unit_setInsertNew = do+  setInsertNew nop @?= setInsertNew'+  setInsertNewValid -$? () @?= Right (S.singleton 5 )+  let setInsertFail = setInsertNewInvalid -$? ()+  assertBool (Debug.show setInsertFail <> " should fail") $ isLeft setInsertFail+  where+    setInsertNew' :: '[Integer, Set Integer] :-> '[Set Integer]+    setInsertNew' = dupTop2 # mem # if_ (nop # failWith) (dip (push True) # update)++    setInsertNewValid :: '[] :-> '[Set Integer]+    setInsertNewValid = emptySet # push 5 # setInsertNew nop++    setInsertNewInvalid :: '[] :-> '[Set Integer]+    setInsertNewInvalid = emptySet # push 5 # setInsertNew nop # push 5 # setInsertNew nop++unit_setDelete :: Assertion+unit_setDelete = do+  setDelete @?= setDelete'+  where+    setDelete' :: '[Integer, Set Integer] :-> '[Set Integer]+    setDelete' = dip (push False) # update++----------------------------------------------------------------------------+-- Morley macros+----------------------------------------------------------------------------++unit_addressToEpAddress :: Assertion+unit_addressToEpAddress = do+  addressToEpAddress @?= addressToEpAddress'+  where+    addressToEpAddress' :: '[Address] :-> '[EpAddress]+    addressToEpAddress' = forcedCoerce_++test_pushContractRef :: [TestTree]+test_pushContractRef =+  [ testScenarioOnEmulator "Invalid contract ref calling fail" $ scenarioEmulated do+      expectFailedWith True $ do+        originatedContract <- originateSimple "target" def $ contract' ref+        call originatedContract CallDefault 1+  , testScenarioOnEmulator "Valid contract ref calling success" $ scenarioEmulated do+      refContract <- originateSimple "caller" () refContract'+      originatedContract <- originateSimple "target" def $ contract' $ toContractRef refContract+      call originatedContract CallDefault 1+  ]+  where+    ref :: ContractRef Integer+    ref = toContractRef $ TAddress $ unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD"++    refContract' :: Contract Integer () ()+    refContract' = defaultContract $ car # drop # unit # nil # pair++    contract' :: ContractRef Integer -> Contract Integer () ()+    contract' rf = defaultContract $+        car #+        pushContractRef @Integer (drop # push True # failWith) rf #+        drop # drop #+        unit # nil # pair++unit_dupTop2 :: Assertion+unit_dupTop2 = do+  dupTop2 @?= dupTop2'+  where+    dupTop2' :: '[Bool, Integer] :-> '[Bool, Integer, Bool, Integer]+    dupTop2' = dupN @2 # dupN @2++unit_fromOption :: Assertion+unit_fromOption = do+  fromOption True @?= fromOption'+  where+    fromOption' :: '[Maybe Bool] :-> '[Bool]+    fromOption' = ifSome nop (push True)++unit_isSome :: Assertion+unit_isSome = do+  isSome @?= isSome'+  where+    isSome' :: '[Maybe Integer] :-> '[Bool]+    isSome' = ifSome (drop # push True) (push False)++unit_non :: Assertion+unit_non = do+  non 1 @?= non_+  where+    non_ :: '[Integer] :-> '[Maybe Integer]+    non_ = non' (push 1 # eq)++unit_non' :: Assertion+unit_non' = do+  non' (push 0 # eq) @?= non'_+  where+    non'_ :: '[Integer] :-> '[Maybe Integer]+    non'_ = dup # framed (push 0 # eq :: Lambda Integer Bool) # if_ (drop # none) L.some++unit_isEmpty :: Assertion+unit_isEmpty = do+  isEmpty @?= isEmpty'+  where+    isEmpty' :: '[[Integer]] :-> '[Bool]+    isEmpty' = size # int # eq0++unit_nonZero :: Assertion+unit_nonZero = do+  nonZero @?= nonZeroI+  nonZero @?= nonZeroN+  nonZero @?= nonZeroT+  where+    nonZeroI :: '[Integer] :-> '[Maybe Integer]+    nonZeroI = dup # eq0 # if_ (drop # none) L.some++    nonZeroN :: '[Natural] :-> '[Maybe Natural]+    nonZeroN = dup # int # eq0 # if_ (drop # none) L.some++    nonZeroT :: '[Ticket Natural] :-> '[Maybe (Ticket Natural)]+    nonZeroT = readTicket # toField #rtAmount # int # eq0 # if_ (drop # none) L.some++----------------------------------------------------------------------------+-- Execute and applicate+----------------------------------------------------------------------------  test_execute :: [TestTree] test_execute =

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for checking MorleyLogs processing. module Test.Lorentz.MorleyLogs@@ -17,15 +16,21 @@ import Test.Cleveland import Test.Cleveland.Michelson (testTreesWithUntypedContract) +singleLog :: Lorentz.Contract () () ()+singleLog = defaultContract $+  printComment "log" # car # nil # pair++multiLog :: Lorentz.Contract () () ()+multiLog = defaultContract $+  printComment "log1" # car # nil # printComment "log2" # pair # printComment "log3"+ test_MorleyLogs :: IO [TestTree] test_MorleyLogs =   testTreesWithUntypedContract "../../contracts/empties.tz" $ \withoutLogs ->-  testTreesWithUntypedContract "../../contracts/single_log.mtz" $ \withSingleLog ->-  testTreesWithUntypedContract "../../contracts/multiple_logs.mtz" $ \withMultiLogs ->   pure   [ testGroup "Checking MorleyLogs processing"     [ testScenarioOnEmulator "Calling contract with single log" $ scenarioEmulated do-        idAddr <- originateS withSingleLog+        idAddr <- originateS         logsInfo <- getMorleyLogs_ $ do           call idAddr CallDefault ()           call idAddr CallDefault ()@@ -34,8 +39,8 @@      , testScenarioOnEmulator "Calling several contracts with and without logs" $ scenarioEmulated do         idAddrW <- originateW withoutLogs-        idAddrS <- originateS withSingleLog-        idAddrM <- originateM withMultiLogs+        idAddrS <- originateS+        idAddrM <- originateM         logsInfo <- getMorleyLogs_ $ do           call idAddrW CallDefault ()           call idAddrS CallDefault ()@@ -46,8 +51,8 @@         collectLogs logsInfo @== MorleyLogs ["log", "log1", "log2", "log3"]      , testScenarioOnEmulator "Calling several contracts to check the logging order" $ scenarioEmulated do-        idAddrS <- originateS withSingleLog-        idAddrM <- originateM withMultiLogs+        idAddrS <- originateS+        idAddrM <- originateM         logsInfo <- getMorleyLogs_ $ do           call idAddrS CallDefault ()           call idAddrM CallDefault ()@@ -59,13 +64,13 @@     , testScenarioOnEmulator "Calling contracts in parallel with branchout" $ scenarioEmulated do         branchout           [ ("1", do-            idAddr <- originateS withSingleLog+            idAddr <- originateS             logsInfo <- getMorleyLogs_ $               call idAddr CallDefault ()             logsForAddress idAddr logsInfo @== fmap MorleyLogs [["log"]])            , ("2", do-            idAddr <- originateS withSingleLog+            idAddr <- originateS             logsInfo <- getMorleyLogs_ $               call idAddr CallDefault ()             collectLogs logsInfo @== MorleyLogs ["log"])@@ -93,13 +98,15 @@         UntypedOriginateData name 100 ValueUnit c       return $ toTAddress addr -    originateW, originateS, originateM+    originateW       :: forall caps m. MonadCleveland caps m       => Morley.Michelson.Untyped.Contract       -> m (TAddress () ())     originateW = originateContract "without logs"-    originateS = originateContract "with single log"-    originateM = originateContract "with multiple logs"++    originateS, originateM :: MonadCleveland caps m => m (ContractHandle () () ())+    originateS = originateSimple "with single log" () singleLog+    originateM = originateSimple "with multiple logs" () multiLog      callerContract :: Lorentz.Contract (ContractRef Integer) () ()     callerContract = defaultContract $

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for optimization of Lorentz-specific instruction sequences. module Test.Lorentz.Optimizer@@ -10,7 +9,7 @@   ) where  import Lorentz ((#), (:->))-import qualified Lorentz as L+import Lorentz qualified as L import Morley.Michelson.Optimizer (optimize) import Morley.Michelson.Typed.Util (linearizeLeft) import Test.HUnit (Assertion, (@?=))

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz packing/unpacking @@ -8,9 +7,11 @@   ( test_lambda_roundtrip   ) where +import Debug qualified (show) import Lorentz import Prelude hiding (drop, swap) +import Fmt (pretty) import Test.HUnit (Assertion, assertFailure, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase)@@ -34,15 +35,14 @@   => Lambda i o   -> Assertion lambdaRoundtripWithoutNotes l = case lUnpackValueRaw @(Lambda i o) $ lPackValueRaw l of-  Left err -> assertFailure $ "Unpacking error: " <> show err+  Left err -> assertFailure $ "Unpacking error: " <> pretty err   Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of     [] -> ul @?= l-    notes -> assertFailure $ "Lambda has annotations: " <> show notes+    notes -> assertFailure $ "Lambda has annotations: " <> pretty notes   where-    dfsSettings :: DfsSettings [Text]     dfsSettings = def { dsGoToValues = True}      instrNotes :: Instr inp out -> [Text]     instrNotes = \case-      InstrWithNotes _ n _ -> [show n]+      InstrWithNotes _ n _ -> [Debug.show n]       _ -> []

@@ -1,16 +1,16 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on Lorentz contracts pretty-printing. module Test.Lorentz.Print   ( test_Print_parameter_annotations   , test_Print_lambda   , unit_Erase_annotations+  , unit_Does_not_erase_annotations   ) where  import Lorentz hiding (contract, unpack)-import qualified Lorentz as L+import Lorentz qualified as L import Prelude hiding (drop, swap)  import Test.HUnit (Assertion, assertEqual, (@?=))@@ -57,8 +57,8 @@   ]  data TestParam-  = TestCon1 ("a" :! Natural, "b" :! Bool)-  | TestCon2 ()+  = TestCon1 ("a" :! Natural, "b" :! Natural)+  | TestCon2 Bool   deriving stock Generic   deriving anyclass IsoValue @@ -68,12 +68,52 @@ unit_Erase_annotations :: Assertion unit_Erase_annotations =   let-    myContract :: Contract TestParam () ()+    myContract :: Contract TestParam Bool ()     myContract = defaultContract $-      cdr # nil # L.pair+        car+      # entryCase @TestParam (Proxy @PlainEntrypointsKind)+        ( #cTestCon1 /->+              unpair+            # dip (fromNamed #b)+            # fromNamed #a+            # eq+        , #cTestCon2 /-> nop+        )+      # nil+      # L.pair -    expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };"+    expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\+      \code { CAST (pair (or (pair nat nat) bool) bool);CAR;IF_LEFT { UNPAIR;COMPARE;EQ }\+      \        {  };NIL operation;PAIR };"   in assertEqual       "Printed Lorentz contract is supposed to have an instruction which erases\-      \all parameter annotations, but it does not match the expected output"+      \all parameter annotations, if the contract doesn't typecheck,\+      \ but it does not match the expected output"+      expected (L.printLorentzContract True myContract)++unit_Does_not_erase_annotations :: Assertion+unit_Does_not_erase_annotations =+  let+    myContract :: Contract TestParam Bool ()+    myContract = defaultContract $+        car+      # entryCase @TestParam (Proxy @PlainEntrypointsKind)+        ( #cTestCon1 /->+              unpair+            # dip (fromNamed #b)+            # fromNamed #a+            # dropN @2+            # push False+        , #cTestCon2 /-> nop+        )+      # nil+      # L.pair++    expected = "parameter (or (pair %testCon1 (nat :a) (nat :b)) (bool %testCon2));storage bool;\+      \code { CAR;IF_LEFT { UNPAIR;DROP 2;PUSH bool False }\+      \        {  };NIL operation;PAIR };"+  in assertEqual+      "Printed Lorentz contract is supposed to NOT have an instruction which erases\+      \all parameter annotations, if the contract DOES typecheck,\+      \ but it does not match the expected output"       expected (L.printLorentzContract True myContract)

@@ -0,0 +1,94 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Tests on product type utilities.+module Test.Lorentz.Product+  ( test_getField_and_dupables+  ) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Lorentz+import Morley.Michelson.Typed.Instr+import Morley.Util.Instances ()++-- | A dupable type+type D = ()++-- | A non-dupable type+type ND = Ticket ()++data SmallDupable = SmallDupable+  { _sd1 :: D+  , _sd2 :: D+  , _sd3 :: D+  , _sd4 :: D+  } deriving stock (Generic)+    deriving anyclass (IsoValue)++data BigDupable = BigDupable+  { _bd1 :: SmallDupable+  , _bd2 :: D+  , _bd3 :: D+  , _bd4 :: D+  } deriving stock (Generic)+    deriving anyclass (IsoValue, HasDupableGetters)++data SmallHalfDupable = SmallHalfDupable+  { _shd1 :: D+  , _shd2 :: D+  , _shd3 :: D+  , _shd4 :: ND+  } deriving stock (Generic)+    deriving anyclass (IsoValue, HasDupableGetters)++data BigHalfDupable1 = BigHalfDupable1+  { _bhd1 :: SmallDupable+  , _bhd2 :: D+  , _bhd3 :: D+  , _bhd4 :: SmallHalfDupable+  } deriving stock (Generic)+    deriving anyclass (IsoValue, HasDupableGetters)++-- | Here we primarily want to test that getters are optimal+-- (taking the existance of non-dupable types into account):+-- if halfway we can apply 'DUP' and end with a sequence of 'CAR' and 'CDR',+-- we should do so.+test_getField_and_dupables :: [TestTree]+test_getField_and_dupables =+  [ testGroup "Direct field access"++    [ testCase "Picking from dupable" $+        getField @SmallDupable #_sd1 @?= I do+          DUP :# CAR :# CAR++    , testCase "Picking from product becoming dupable half-way" $+        getField @SmallHalfDupable #_shd1 @?= I do+          UNPAIR :# DUP :# CAR :# DIP PAIR++    , testCase "Picking from product that is non-dupable all the way along" $+        getField @SmallHalfDupable #_shd3 @?= I do+          UNPAIR :# SWAP :# (UNPAIR :# DUP :# DIP PAIR) :# DIP (SWAP :# PAIR)++    ]++  , testGroup "Nested field access"++    [ testCase "Picking from dupable" $+        stGetField @BigDupable (#_bd1 :-| #_sd1) @?= I do+          DUP :# CAR :# CAR :# CAR :# CAR++    , testCase "Deep picking from dupable nested type" $+        stGetField @BigHalfDupable1 (#_bhd1 :-| #_sd1) @?= I do+          UNPAIR :# DUP :# CAR :# CAR :# CAR :# DIP PAIR++    , testCase "Deep picking from non-dupable nested type" $+        stGetField @BigHalfDupable1 (#_bhd4 :-| #_shd1) @?= I do+          UNPAIR :# SWAP :# UNPAIR :# SWAP+            :# (UNPAIR :# DUP :# CAR :# DIP PAIR)+            :# DIP (SWAP :# PAIR) :# DIP (SWAP :# PAIR)++    ]++  ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'Lorentz.NameReferenced' module. --

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on Lorentz storage annotation parsing. @@ -14,7 +13,7 @@ import Test.Tasty.HUnit (testCase)  import Lorentz ((:!))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Annotation (HasAnnotation) import Lorentz.Run hiding (Contract(..)) import Lorentz.Value@@ -85,7 +84,7 @@   } deriving stock Generic     deriving anyclass (IsoValue, HasAnnotation) -dummyContract :: forall storage. L.NiceStorage storage => L.Contract () storage ()+dummyContract :: forall storage. L.NiceStorageFull storage => L.Contract () storage () dummyContract = defaultContract L.fakeCoerce  ----------------------------------------------------------------------------@@ -135,7 +134,7 @@     storageAnnTree :: Contract cp st -> FieldAnnTree st     storageAnnTree = extractFieldAnnTree . cStoreNotes -    extractAnnotation :: forall st. L.NiceStorage st => FieldAnnTree (ToT st)+    extractAnnotation :: forall st. L.NiceStorageFull st => FieldAnnTree (ToT st)     extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st)  test_TypeAnnotations :: [TestTree]@@ -192,5 +191,5 @@     storageAnnTree :: Contract cp st -> TypeAnnTree st     storageAnnTree = extractTypeAnnTree . cStoreNotes -    extractAnnotation :: forall st. L.NiceStorage st => TypeAnnTree (ToT st)+    extractAnnotation :: forall st. L.NiceStorageFull st => TypeAnnTree (ToT st)     extractAnnotation = storageAnnTree $ L.toMichelsonContract (dummyContract @st)

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Lorentz.StoreClass.ComplexRefs   ( test_Nested@@ -14,10 +13,9 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@?=)) -import Lorentz.Annotation (HasAnnotation) import Lorentz.Run.Simple import Lorentz.StoreClass-import qualified Lorentz.StoreClass.Extra as E+import Lorentz.StoreClass.Extra qualified as E import Lorentz.Value import Morley.Util.Lens import Morley.Util.Named@@ -26,18 +24,18 @@ data Storage = Storage   { sField1 :: SubStorage   } deriving stock (Eq, Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation)+    deriving anyclass (IsoValue)  data SubStorage = SubStorage   { ssField1 :: Group   } deriving stock (Eq, Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation)+    deriving anyclass (IsoValue)  data Group = Group   { gField :: Integer   , gSubmap :: Map MText Natural   } deriving stock (Eq, Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation)+    deriving anyclass (IsoValue)  makeLensesWith postfixLFields ''Storage makeLensesWith postfixLFields ''SubStorage

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Lorentz.StoreClass.SetSubmap   ( test_Simple_set@@ -8,12 +7,11 @@  import Prelude hiding (drop, swap) -import qualified Data.Set as S+import Data.Set qualified as S import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import qualified Lorentz as L-import Lorentz.Annotation (HasAnnotation)+import Lorentz qualified as L import Lorentz.Base import Lorentz.Constraints import Lorentz.Run.Simple@@ -28,7 +26,7 @@ data Storage = Storage   { x :: Set MText   } deriving stock (Eq, Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation)+    deriving anyclass (IsoValue)  emptyStorage :: Storage emptyStorage = Storage mempty

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Lorentz.StoreClass.StorageEntrypoints   ( test_Storage_entrypoints@@ -35,7 +34,7 @@   | GetValue (View_ () Natural)   | SetSubNat (EntrypointLambda Natural Natural)   deriving stock Generic-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints ParameterEpTest where   type ParameterEntrypointsDerivation ParameterEpTest = EpdPlain

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Lorentz.StoreClass.SubmapZoom   ( test_Simple_part_of_value@@ -10,12 +9,11 @@  import Prelude hiding (drop, swap) -import qualified Data.Map as M+import Data.Map qualified as M import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import qualified Lorentz as L-import Lorentz.Annotation (HasAnnotation)+import Lorentz qualified as L import Lorentz.Base import Lorentz.Constraints import Lorentz.Iso@@ -34,7 +32,7 @@ data Storage = Storage   { all :: BigMap MText MapValue   } deriving stock (Eq, Show, Generic)-    deriving anyclass (IsoValue, HasAnnotation)+    deriving anyclass (IsoValue)  instance StoreHasSubmap Storage (FieldNickname "x") MText Natural where   storeSubmapOps =

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on basic tickets functionality. --

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE NoApplicativeDo #-}@@ -130,7 +129,7 @@   | AllowancesAllow (Ticket ())   | AllowancesGet (Void_ Address Natural)   deriving stock (Generic)-  deriving anyclass (IsoValue, HasAnnotation)+  deriving anyclass (IsoValue)  instance ParameterHasEntrypoints AllowancesParameter where   type ParameterEntrypointsDerivation AllowancesParameter = EpdPlain

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on tickets helpers from "Lorentz.Tickets" module. module Test.Lorentz.Tickets.Helpers@@ -10,7 +9,7 @@  import Test.Tasty (TestTree, testGroup) -import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Value import Morley.Util.Named import Test.Cleveland@@ -166,3 +165,5 @@ -} _untestedContract1 :: [TestTree] _untestedContract1 = const [] allowancesContract++{-# ANN _untestedContract1 ("HLint: ignore Evaluate" :: Text) #-}

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on basic timelock puzzle, i.e. 'openChest' functionality module Test.Lorentz.Timelock@@ -11,8 +10,8 @@ import Prelude (Num, fst, id, snd, (/=), (<$>))  import Hedgehog (forAll, property, withTests, (===))-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz 'UParam'. module Test.Lorentz.UParam@@ -10,12 +9,13 @@   ) where  import Data.Constraint (Dict(..))+import Fmt (Buildable, pretty) import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase)  import Lorentz ((/->))-import qualified Lorentz as L+import Lorentz qualified as L import Lorentz.Base import Lorentz.Run.Simple import Lorentz.UParam@@ -65,7 +65,7 @@     unpk ::       UParam Entries ->       Either EntrypointLookupError (MText, String)-    unpk = fmap (second show) . unpackUParam @Show+    unpk = fmap (second pretty) . unpackUParam @Buildable  -- Test ADT conversion ----------------------------------------------------------------------------

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz on-chain views. 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on importing Lorentz contracts with views. @@ -11,11 +10,12 @@ import Lorentz import Prelude hiding (drop, some, swap, take, view) +import Morley.Util.MismatchError import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Util.Contracts -import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Test.Cleveland.Lorentz.Import  data AllViews@@ -74,12 +74,13 @@   , testCase "One view with wrong arg type" do       importContract' @WrongIdView1         `catch` \e ->-          e @?= VIMViewArgMismatch T.TNat T.TInt+          e @?= VIMViewArgMismatch MkMismatchError{meActual=T.TNat, meExpected=T.TInt}    , testCase "One view with wrong ret type" do       importContract' @WrongIdView2         `catch` \e ->-          e @?= VIMViewRetMismatch (T.TPair T.TNat T.TUnit) (T.TPair T.TInt T.TUnit)+          e @?= VIMViewRetMismatch MkMismatchError+            {meActual=T.TPair T.TNat T.TUnit, meExpected=T.TPair T.TInt T.TUnit}    , testCase "Non-existent view" do       importContract' @NonExistentView@@ -92,5 +93,5 @@   , testCase "All views and one wrong view" do       importContract' @WrongViewsSet         `catch` \e ->-          e @?= VIMViewRetMismatch T.TNever T.TUnit+          e @?= VIMViewRetMismatch MkMismatchError{meActual=T.TNever, meExpected=T.TUnit}   ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tasty integration for TypeSpec. module Test.Tasty.TypeSpec@@ -14,11 +13,13 @@   forall expectation. PrettyTypeSpec expectation =>   TypeTestCase (TypeSpec expectation) +-- According to documentation of TypeSpec, the only sensible thing we can+-- do with the spec value is to print it.+type instance PrettyShow (TypeSpec _) = ()+ instance IsTest TypeTestCase where   -- Implementation here is similar to the one from HUnit integration   run _ (TypeTestCase spec) _ =-    -- According to documentation of TypeSpec, the only sensible thing we can-    -- do with spec value is to print it.     -- TypeSpec test suites are ensured at compile time.     return . testPassed $ show spec 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Util.Annotation   ( FieldAnnTree (..)@@ -81,3 +80,5 @@   NTNever ta -> TALeaf ta   NTChest ta -> TALeaf ta   NTChestKey ta -> TALeaf ta+  NTSaplingState ta _ -> TALeaf ta+  NTSaplingTransaction ta _ -> TALeaf ta

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Util.TypeSpec   ( ExactlyIs@@ -9,7 +8,7 @@ import Data.Singletons.Prelude.Eq (DefaultEq) import Morley.Util.Type (If) import Morley.Util.TypeLits (ErrorMessage(..))-import Test.TypeSpec.Core+import Test.TypeSpec.Core (EvalExpectation, FAILED, OK, PrettyTypeSpec(..))  -- | Like 'Is' but ensures that arguments match in kind. data ExactlyIs (actual :: k) (expected :: k)

@@ -1,11 +1,10 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Main (main) where  import Data.Default (def)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Gauge.Main (bench, bgroup, defaultMain, nf) import Main.Utf8 (withUtf8) import Text.Megaparsec (parse)@@ -48,7 +47,7 @@       )      dummyAddress = detGenKeyAddress "thegreatandpowerful"-    dummyString = unsafeMkMText "TGAP"+    dummyString = unsafe . mkMText $ "TGAP"     stringCallerBench = bench stringCallerFp       (nf         (interpret stringCallerC T.epcPrimitive  (T.toVal dummyString) (T.toVal dummyAddress) dummyGlobalCounter dummyBigMapCounter)

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Main   ( main

@@ -1,30 +1,37 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for fee calculation implementation in 'morley-client'. module Test.Fee   ( test_FeeCalculation   ) where -import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Morley.Client.Action (transfer) import Morley.Client.Action.Common-  (OriginationData(..), TD(..), TransactionData(..), computeStorageLimit)+  (OriginationData(..), RevealData(..), TD(..), TransactionData(..), computeStorageLimit,+  revealKeyUnlessRevealed) import Morley.Client.Action.Operation (dryRunOperationsNonEmpty) import Morley.Client.Full (runMorleyClientM)+import Morley.Client.OnlyRPC import Morley.Client.RPC.Getters (getProtocolParameters)-import Morley.Client.TezosClient.Impl (calcOriginationFee, calcTransferFee)+import Morley.Client.TezosClient.Impl+  (calcOriginationFee, calcRevealFee, calcTransferFee, importKey) import Morley.Client.TezosClient.Types-  (AddressOrAlias(..), CalcOriginationFeeData(..), CalcTransferFeeData(..))+  (AddressOrAlias(..), AliasOrAliasHint(..), CalcOriginationFeeData(..), CalcTransferFeeData(..))+import Morley.Client.Types import Morley.Micheline.Json (TezosMutez(..)) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.Typed (IsoValue(..)) import Morley.Michelson.Untyped (pattern DefEpName)-import Morley.Tezos.Core (toMutez, zeroMutez)-import Test.Cleveland (NetworkEnv(neMorleyClientEnv))+import Morley.Tezos.Address+import Morley.Tezos.Core (tz, zeroMutez)+import Morley.Tezos.Crypto+import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519+import Test.Cleveland (NetworkEnv(neMorleyClientEnv), mkMorleyOnlyRpcEnvNetwork) import Test.Cleveland.Internal.Abstract (Moneybag(..)) import Test.Cleveland.Internal.Client (setupMoneybagAddress) import Test.Cleveland.Michelson.Import (importContract)@@ -49,11 +56,13 @@         , odStorage = toVal ()         , odMbFee = Nothing         }+    , testCase "reveal has the same fee" $ do+      compareRevealFeeCalculation withEnv     ]   where     trivialTransfer = TransactionData $ TD       { tdReceiver = genesisAddress-      , tdAmount = toMutez 100+      , tdAmount = 100       , tdEpName = DefEpName       , tdParam = toVal ()       , tdMbFee = Nothing@@ -63,8 +72,9 @@   :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> NonEmpty TransactionData -> Assertion compareTransferFeeCalculation withEnv transferBatch = withEnv $ \env -> do   Moneybag moneybagAddr <- setupMoneybagAddress env+  runMorleyClientM (neMorleyClientEnv env) $ revealKeyUnlessRevealed moneybagAddr Nothing   (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $-    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (map Left transferBatch)+    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (map OpTransfer transferBatch)   pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters   feesTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcTransferFee     (AddressResolved moneybagAddr) Nothing (computeStorageLimit appliedResults pp)@@ -83,8 +93,9 @@   :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> OriginationData -> Assertion compareOriginationFeeCalculation withEnv od@OriginationData{..} = withEnv $ \env -> do   Moneybag moneybagAddr <- setupMoneybagAddress env+  runMorleyClientM (neMorleyClientEnv env) $ revealKeyUnlessRevealed moneybagAddr Nothing   (appliedResults, feesMorleyClient) <- fmap (unzip . toList) $ runMorleyClientM (neMorleyClientEnv env) $-    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (one $ Right od)+    dryRunOperationsNonEmpty (AddressResolved moneybagAddr) (one $ OpOriginate od)   pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters   feeTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcOriginationFee     CalcOriginationFeeData@@ -96,3 +107,26 @@       , cofdBurnCap = computeStorageLimit appliedResults pp       }   feesMorleyClient @?= [feeTezosClient]++compareRevealFeeCalculation+  :: ((forall a. (NetworkEnv -> IO a) -> IO a)) -> Assertion+compareRevealFeeCalculation withEnv = withEnv $ \env -> do+  sk <- SecretKeyEd25519 <$> liftIO Ed25519.randomSecretKey+  let pub = toPublic sk+  let addr = mkKeyAddress pub++  alias <- runMorleyClientM (neMorleyClientEnv env) do+    alias <- importKey True (AnAliasHint "rpc-revealed-key") sk+    Moneybag moneybag <- liftIO $ setupMoneybagAddress env+    void $ transfer moneybag addr [tz|1 milli|] DefEpName (toVal ()) Nothing+    return alias++  (appliedResults, feesRPC) :| [] <- runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) do+    let rd = RevealData{ rdPublicKey = pub, rdMbFee = Nothing }+    dryRunOperationsNonEmpty (AddressResolved addr) (one $ OpReveal rd)++  pp <- runMorleyClientM (neMorleyClientEnv env) getProtocolParameters+  feesTezosClient <- runMorleyClientM (neMorleyClientEnv env) $ calcRevealFee+    alias Nothing (computeStorageLimit [appliedResults] pp)++  feesRPC @?= feesTezosClient

@@ -0,0 +1,67 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Tests on key revealing performed via RPC.+module Test.RPCKeyRevealing+  ( test_rpcKeyRevealing+  ) where++import Crypto.Random (getRandomBytes)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Morley.Client.Action qualified as WithTezosClient+import Morley.Client.Action.Reveal+import Morley.Client.Full qualified as WithTezosClient+import Morley.Client.OnlyRPC+import Morley.Client.RPC.Getters as WithTezosClient+import Morley.Client.TezosClient qualified as WithTezosClient+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Address+import Morley.Tezos.Core+import Morley.Tezos.Crypto+import Test.Cleveland+import Test.Cleveland.Tasty++test_rpcKeyRevealing :: TestTree+test_rpcKeyRevealing =+  whenNetworkEnabled $ \withEnv ->+  testGroup "Key revealing via RPC"+  [ testCase "Can reveal a new key" $ withEnv \env -> do+      sk <- detSecretKey <$> liftIO (getRandomBytes 16)+      let pub = toPublic sk+      let addr = mkKeyAddress pub++      WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do+        WithTezosClient.importKey True (WithTezosClient.AnAliasHint "rpc-revealed-key") sk+        moneybag <- WithTezosClient.resolveAddress (WithTezosClient.AddressAlias $ neMoneybagAlias env)+        void $ WithTezosClient.transfer moneybag addr [tz|1 milli|] U.DefEpName T.VUnit Nothing++      opHash <- runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) $ do+        revealKey addr $+          RevealData pub Nothing++      mManager <- WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do+        WithTezosClient.waitForOperation opHash+        getManagerKey addr++      mManager @?= Just pub++  , testCase "revealKeyUnlessRevealed works" $ withEnv \env -> do+      sk <- detSecretKey <$> liftIO (getRandomBytes 16)+      let pub = toPublic sk+      let addr = mkKeyAddress pub++      WithTezosClient.runMorleyClientM (neMorleyClientEnv env) $ do+        WithTezosClient.importKey True (WithTezosClient.AnAliasHint "rpc-revealed-key") sk+        moneybag <- WithTezosClient.resolveAddress (WithTezosClient.AddressAlias $ neMoneybagAlias env)+        void $ WithTezosClient.transfer moneybag addr [tz|1 milli|] U.DefEpName T.VUnit Nothing++      runMorleyOnlyRpcM (mkMorleyOnlyRpcEnvNetwork env [sk]) $ do+        void . revealKey addr $+          RevealData pub Nothing+        void . revealKeyUnlessRevealed addr $+          RevealData pub Nothing++  ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Main   ( main

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for analyzer. @@ -10,12 +9,12 @@  import Prelude hiding (EQ) -import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict qualified as HM import Test.HUnit (Assertion, (@?=))  import Morley.Michelson.Analyzer import Morley.Michelson.Text-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Test.Cleveland.Instances () 

@@ -0,0 +1,647 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_GHC -Wno-star-is-type #-}++module Test.AsRPC+  ( unit_Renames_constructors_fields_and_generic_metadata+  , unit_Can_derive_many_instances_at_once+  , unit_Supports_higher_kinded_types+  , unit_Can_derive_instances_with_newtype+  , unit_Can_derive_many_instances_with_newtypes+  , unit_Can_derive_many_instances_with_type_aliases+  ) where++import Data.Typeable ((:~:)(Refl))+import GHC.Generics+  (C1, D1, DecidedStrictness(..), FixityI(..), Generic(..), K1(..), M1(..), Meta(..), Rec0, S1,+  SourceStrictness(..), SourceUnpackedness(..), (:*:)(..))+import Language.Haskell.TH.Syntax qualified as TH+import Test.Tasty.HUnit (Assertion)++import Lorentz (BigMap, BigMapId, IsoValue(ToT), MText, customGeneric, leftBalanced, ligoLayout)+import Morley.AsRPC++import Test.Util.TH (shouldCompileIgnoringInstance, shouldCompileTo)++data ExampleStorage a b = ExampleStorage+  { _esField1 :: Integer+  , _esField2 :: [BigMap Integer MText]+  , _esField3 :: a+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "ExampleStorage"++unit_Renames_constructors_fields_and_generic_metadata :: Assertion+unit_Renames_constructors_fields_and_generic_metadata = do+  $(deriveRPC "ExampleStorage" >>= TH.lift) `shouldCompileTo`+    [d|+      data ExampleStorageRPC a (b :: k) = ExampleStorageRPC+        { _esField1RPC :: AsRPC Integer+        , _esField2RPC :: AsRPC [BigMap Integer MText]+        , _esField3RPC :: AsRPC a+        }++      instance (HasRPCRepr a) => HasRPCRepr (ExampleStorage a (b :: k)) where+        type AsRPC (ExampleStorage a (b :: k)) = ExampleStorageRPC a (b :: k)++      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (ExampleStorageRPC a (b :: k))++      instance Generic (ExampleStorageRPC a (b :: k))+          where type Rep (ExampleStorageRPC a+                                      (b :: k)) = D1 ('MetaData "ExampleStorageRPC" "Test.AsRPC" "main" 'False)+                                                      (C1 ('MetaCons "ExampleStorageRPC" 'PrefixI 'True)+                                                          ((:*:) (S1 ('MetaSel ('Just "_esField1RPC")+                                                                              'NoSourceUnpackedness+                                                                              'NoSourceStrictness+                                                                              'DecidedStrict)+                                                                    (Rec0 (AsRPC Integer)))+                                                                ((:*:) (S1 ('MetaSel ('Just "_esField2RPC")+                                                                                      'NoSourceUnpackedness+                                                                                      'NoSourceStrictness+                                                                                      'DecidedStrict)+                                                                            (Rec0 (AsRPC ([BigMap Integer+                                                                                                  MText]))))+                                                                        (S1 ('MetaSel ('Just "_esField3RPC")+                                                                                      'NoSourceUnpackedness+                                                                                      'NoSourceStrictness+                                                                                      'DecidedStrict)+                                                                            (Rec0 (AsRPC a))))))+                from (ExampleStorageRPC v0+                                  v1+                                  v2) = M1 (M1 ((:*:) (M1 (K1 v0)) ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))+                to (M1 (M1 ((:*:) (M1 (K1 v0))+                                  ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))) = ExampleStorageRPC v0 v1 v2+    |]++data Ex1 = Ex1 Integer Ex1Inner+  deriving stock Generic+  deriving anyclass IsoValue+data Ex1Inner = Ex1Inner Integer+  deriving stock Generic+  deriving anyclass IsoValue++data Ex2 = Ex2 Integer+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "Ex2"++data Ex3 = Ex3 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Ex4 a = Ex4 a+  deriving stock Generic+  deriving anyclass IsoValue++data ExampleMany = ExampleMany+  { _emField1 :: Integer+  , _emField2 :: Ex1+  , _emField3 :: Ex2+  , _emField4 :: [BigMap Ex3 (Ex4 MText)]+  }+  deriving stock Generic+  deriving anyclass IsoValue++-- Check that the declarations generated by `deriveManyRPC` actually compile.+deriveManyRPC "ExampleMany" []++unit_Can_derive_many_instances_at_once :: Assertion+unit_Can_derive_many_instances_at_once = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleMany" ["Ex3"] >>= TH.lift)+    [d|+      data ExampleManyRPC = ExampleManyRPC+        {_emField1RPC :: AsRPC Integer+        , _emField2RPC :: AsRPC Ex1+        , _emField3RPC :: AsRPC Ex2+        , _emField4RPC :: AsRPC [BigMap Ex3 (Ex4 MText)]+        }+      instance HasRPCRepr ExampleMany where type AsRPC ExampleMany = ExampleManyRPC+      deriving anyclass instance IsoValue ExampleManyRPC++      -- An instance is generated for Ex1+      data Ex1RPC = Ex1RPC (AsRPC Integer) (AsRPC Ex1Inner)+      instance HasRPCRepr Ex1 where type AsRPC Ex1 = Ex1RPC+      deriving anyclass instance IsoValue Ex1RPC++      -- An instance is generated for Ex1's fields' types+      data Ex1InnerRPC = Ex1InnerRPC (AsRPC Integer)+      instance HasRPCRepr Ex1Inner where type AsRPC Ex1Inner = Ex1InnerRPC+      deriving anyclass instance IsoValue Ex1InnerRPC++      -- No instance is generated for Ex2, because one already exists++      -- No instance is generated for Ex3, because we explicitly said we don't want one++      -- An instance is generated for BigMap's concrete type arguments+      data Ex4RPC a = Ex4RPC (AsRPC a)+      instance HasRPCRepr a => HasRPCRepr (Ex4 a) where type AsRPC (Ex4 a) = Ex4RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Ex4RPC a)+    |]++----------------------------------------------------------------------------+-- Examples data types:+--+-- Simple data type+----------------------------------------------------------------------------++data Simple = Simple Integer Integer [Integer]+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "Simple"++data ExpectedSimpleRPC = ExpectedSimpleRPC Integer Integer [Integer]+  deriving stock Generic+  deriving anyclass IsoValue++_checkSimple :: ToT SimpleRPC :~: ToT ExpectedSimpleRPC+_checkSimple = Refl++----------------------------------------------------------------------------+-- Simple record data type+----------------------------------------------------------------------------++data SimpleRecord = SimpleRecord+  { _simpleRecordField1 :: Integer+  , _simpleRecordField2 :: Integer+  , _simpleRecordField3 :: [Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "SimpleRecord"++data ExpectedSimpleRecordRPC = ExpectedSimpleRecordRPC+  { eSimpleRecordField1 :: Integer+  , eSimpleRecordField2 :: Integer+  , eSimpleRecordField3 :: [Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkSimpleRecord :: ToT SimpleRecordRPC :~: ToT ExpectedSimpleRecordRPC+_checkSimpleRecord = Refl++----------------------------------------------------------------------------+-- Data type with bigmap fields+----------------------------------------------------------------------------++data WithBigMap = WithBigMap+  { _wbmField1 :: Integer+  , _wbmField2 :: BigMap Integer Integer+  , _wbmField3 :: [BigMap Integer Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithBigMap"++data ExpectedWithBigMapRPC = ExpectedWithBigMapRPC+  { expectedWbmField1 :: Integer+  , expectedWbmField2 :: BigMapId Integer Integer+  , expectedWbmField3 :: [BigMapId Integer Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithBigMap :: ToT WithBigMapRPC :~: ToT ExpectedWithBigMapRPC+_checkWithBigMap = Refl++----------------------------------------------------------------------------+-- Data type with custom generic strategy+----------------------------------------------------------------------------++data WithGenericStrategy+  = WithGenericStrategy_1 Integer Integer Integer+  | WithGenericStrategy_2 Integer Integer Integer+  | WithGenericStrategy_3 Integer Integer Integer+  | WithGenericStrategy_4 Integer Integer Integer++deriving anyclass instance IsoValue WithGenericStrategy+customGeneric "WithGenericStrategy" leftBalanced+deriveRPCWithStrategy "WithGenericStrategy" leftBalanced++_checkWithGenericStrategy :: ToT WithGenericStrategyRPC :~: ToT WithGenericStrategy+_checkWithGenericStrategy = Refl++----------------------------------------------------------------------------+-- Data type with reordered fields+----------------------------------------------------------------------------++data WithReordered = WithRedordered+  { _wrField1 :: Integer+  , _wrField3 :: MText+  , _wrField2 :: [Integer]+  }++deriving anyclass instance IsoValue WithReordered+customGeneric "WithReordered" ligoLayout+deriveRPCWithStrategy "WithReordered" ligoLayout++_checkWithReordered :: ToT WithReorderedRPC :~: ToT WithReordered+_checkWithReordered = Refl++----------------------------------------------------------------------------+-- Data type with type variables+----------------------------------------------------------------------------++data WithTypeVariables a = WithTypeVariables+  { _wtvField1 :: a+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithTypeVariables"++data ExpectedWithTypeVariablesRPC = ExpectedWithTypeVariablesRPC+  { expectedWtvField1 :: BigMapId Integer MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithTypeVariables :: ToT (WithTypeVariablesRPC (BigMap Integer MText)) :~: ToT ExpectedWithTypeVariablesRPC+_checkWithTypeVariables = Refl++----------------------------------------------------------------------------+-- Data type with nested data types and type variables+----------------------------------------------------------------------------++data WithNested a = WithNested+  { _wnField1 :: WithNested2 a+  , _wnField2 :: [WithNested2 a]+  , _wnField3 :: WithNested2 [a]+  }+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (WithNested a)++data WithNested2 a = WithNested2+  { _wn2Field1 :: a+  , _wn2Field2 :: [a]+  }+  deriving stock Generic+  deriving anyclass IsoValue++deriveManyRPC "WithNested" []++data ExpectedWithNestedRPC = ExpectedWithNestedRPC+  { expectedWnField1 :: ExpectedWithNested2RPC+  , expectedWnField2 :: [ExpectedWithNested2RPC]+  , expectedWnField3 :: ExpectedWithNested2RPC'+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithNested2RPC = ExpectedWithNested2RPC+  { expectedWn2Field1 :: BigMapId Integer MText+  , expectedWn2Field2 :: [BigMapId Integer MText]+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithNested2RPC' = ExpectedWithNested2RPC'+  { expectedWn2Field1' :: [BigMapId Integer MText]+  , expectedWn2Field2' :: [[BigMapId Integer MText]]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithNested2 :: ToT (WithNested2RPC (BigMap Integer MText)) :~: ToT ExpectedWithNested2RPC+_checkWithNested2 = Refl++_checkWithNested :: ToT (WithNestedRPC (BigMap Integer MText)) :~: ToT ExpectedWithNestedRPC+_checkWithNested = Refl++----------------------------------------------------------------------------+-- Data type with phantom type variables+----------------------------------------------------------------------------++data WithPhantom a b c = WithPhantom+  { _wpField1 :: Integer+  , _wpField2 :: b+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithPhantom"++data ExpectedWithPhantomRPC = ExpectedWithPhantomRPC+  { expectedWpField1 :: Integer+  , expectedWpField2 :: MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithPhantom :: ToT (WithPhantomRPC Integer MText (BigMap Integer Integer)) :~: ToT ExpectedWithPhantomRPC+_checkWithPhantom = Refl++----------------------------------------------------------------------------+-- Data type with higher-kinded type variables+----------------------------------------------------------------------------++data WithHigherKind f = WithHigherKind+  { _whkField1 :: WithHigherKindNested f+  }+  deriving stock Generic+deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKind f)++data WithHigherKindNested f = WithHigherKindNested+  { _whknField1 :: f Integer MText+  }+  deriving stock Generic+deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKindNested f)++deriveManyRPC "WithHigherKind" []++unit_Supports_higher_kinded_types :: Assertion+unit_Supports_higher_kinded_types = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "WithHigherKind" [] >>= TH.lift)+    [d|+      data WithHigherKindRPC (f :: * -> * -> *) = WithHigherKindRPC+        { _whkField1RPC :: AsRPC (WithHigherKindNested f)+        }++      instance HasRPCRepr (WithHigherKindNested f) => HasRPCRepr (WithHigherKind (f :: * -> * -> *)) where+        type AsRPC (WithHigherKind (f :: * -> * -> *))+          = WithHigherKindRPC (f :: * -> * -> *)++      deriving anyclass instance IsoValue (AsRPC (WithHigherKindNested f))+        => IsoValue (WithHigherKindRPC (f :: * -> * -> *))++      data WithHigherKindNestedRPC (f :: * -> * -> *) = WithHigherKindNestedRPC+        { _whknField1RPC :: AsRPC (f Integer MText)+        }++      instance HasRPCRepr (f Integer MText) => HasRPCRepr (WithHigherKindNested (f :: * -> * -> *)) where+        type AsRPC (WithHigherKindNested (f :: * -> * -> *))+          = WithHigherKindNestedRPC (f :: * -> * -> *)++      deriving anyclass instance IsoValue (AsRPC (f Integer MText))+        => IsoValue (WithHigherKindNestedRPC (f :: * -> * -> *))+    |]++data ExpectedWithHigherKindRPC = ExpectedWithHigherKindRPC+  { expectedWhkField1 :: ExpectedWithHigherKindNestedRPC+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithHigherKindNestedRPC = ExpectedWithHigherKindNestedRPC+  { expectedWhknField1 :: Map Integer MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithHigherKindNested :: ToT (WithHigherKindNestedRPC Map) :~: ToT ExpectedWithHigherKindNestedRPC+_checkWithHigherKindNested = Refl++_checkWithHigherKind :: ToT (WithHigherKindRPC Map) :~: ToT ExpectedWithHigherKindRPC+_checkWithHigherKind = Refl++----------------------------------------------------------------------------+-- Newtypes allowed with deriveRPC and in deriveManyRPC+----------------------------------------------------------------------------++data Data1 b = Data1 b+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++deriveRPC "Data1"++newtype Nt1 a b = Nt1 [Data1 a]+  deriving stock (Generic, Eq, Ord)+deriving anyclass instance IsoValue a => IsoValue (Nt1 a b)++deriveRPC "Nt1"++unit_Can_derive_instances_with_newtype :: Assertion+unit_Can_derive_instances_with_newtype = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveRPC "Nt1" >>= TH.lift)+    [d|+      newtype Nt1RPC a (b :: k) = Nt1RPC (AsRPC ([Data1 a]))++      instance HasRPCRepr ([Data1 a]) => HasRPCRepr (Nt1 a (b :: k)) where+        type AsRPC (Nt1 a (b :: k)) = Nt1RPC a (b :: k)++      deriving anyclass instance IsoValue (AsRPC ([Data1 a])) => IsoValue (Nt1RPC a (b :: k))+    |]++newtype Nt2 = Nt2 { _nt2field :: Integer }+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt3 a = Nt3 a+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt4 a b = Nt4 (BigMap Integer MText)+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt5 a = Nt5 a+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt6 a = Nt6 (Nt5 a)+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (Nt6 a)++data Data2 a = Data2 (Nt6 a)+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (Data2 a)++data ExampleWithNewtypes = ExampleWithNewtypes+  { _ewnField1 :: Nt3 Nt2+  , _ewnField2 :: Nt4 MText Integer+  , _ewnField3 :: Data2 Integer+  }+  deriving stock Generic+  deriving anyclass IsoValue++deriveManyRPC "ExampleWithNewtypes" []++unit_Can_derive_many_instances_with_newtypes :: Assertion+unit_Can_derive_many_instances_with_newtypes = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleWithNewtypes" [] >>= TH.lift)+    [d|+      data ExampleWithNewtypesRPC = ExampleWithNewtypesRPC+        {_ewnField1RPC :: (AsRPC (Nt3 Nt2))+        , _ewnField2RPC :: (AsRPC (Nt4 MText Integer))+        , _ewnField3RPC :: (AsRPC (Data2 Integer))+        }+++      instance HasRPCRepr ExampleWithNewtypes where+        type AsRPC ExampleWithNewtypes = ExampleWithNewtypesRPC+      deriving anyclass instance IsoValue ExampleWithNewtypesRPC++      newtype Nt3RPC a = Nt3RPC (AsRPC a)+      instance HasRPCRepr a => HasRPCRepr (Nt3 a) where+        type AsRPC (Nt3 a) = Nt3RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt3RPC a)++      newtype Nt2RPC = Nt2RPC {_nt2fieldRPC :: (AsRPC Integer)}+      instance HasRPCRepr Nt2 where+        type AsRPC Nt2 = Nt2RPC+      deriving anyclass instance IsoValue Nt2RPC++      newtype Nt4RPC (a :: k) (b :: k) = Nt4RPC (AsRPC (BigMap Integer MText))+      instance HasRPCRepr (Nt4 (a :: k) (b :: k)) where+        type AsRPC (Nt4 (a :: k) (b :: k)) = Nt4RPC (a :: k) (b :: k)+      deriving anyclass instance IsoValue (Nt4RPC (a :: k) (b :: k))++      data Data2RPC a = Data2RPC (AsRPC (Nt6 a))+      instance HasRPCRepr (Nt6 a) => HasRPCRepr (Data2 a) where+        type AsRPC (Data2 a) = Data2RPC a+      deriving anyclass instance IsoValue (AsRPC (Nt6 a)) => IsoValue (Data2RPC a)++      newtype Nt6RPC a = Nt6RPC (AsRPC (Nt5 a))+      instance HasRPCRepr (Nt5 a) => HasRPCRepr (Nt6 a) where+        type AsRPC (Nt6 a) = Nt6RPC a+      deriving anyclass instance IsoValue (AsRPC (Nt5 a)) => IsoValue (Nt6RPC a)++      newtype Nt5RPC a = Nt5RPC (AsRPC a)+      instance HasRPCRepr a => HasRPCRepr (Nt5 a) where+        type AsRPC (Nt5 a) = Nt5RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt5RPC a)+    |]++----------------------------------------------------------------------------+-- Type aliases allowed with deriveManyRPC+----------------------------------------------------------------------------++type Ty1 = Integer++type Ty2 k v = BigMap k v++type Ty3 phantom = Ty1++data Dt1 = Dt1 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Dt2 a = Dt2 a+  deriving stock Generic+  deriving anyclass IsoValue++type Ty4 = Dt1++type Ty5 a = Dt2 a++data Dt3 k v = Dt3 k v+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++type Ty6 v = Dt3 Integer v++data Dt4 v = Dt4 (Ty6 v)+  deriving stock (Generic, Eq, Ord)+deriving anyclass instance IsoValue v => IsoValue (Dt4 v)++data Dt5 a = Dt5 a+  deriving stock Generic+  deriving anyclass IsoValue++type Ty7 (f :: Type -> Type) = (f Integer)++data Dt6 = Dt6 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Dt7 a b = Dt7 a b+  deriving stock Generic+  deriving anyclass IsoValue++data Dt8 = Dt8 [BigMap Integer MText]+  deriving stock Generic+  deriving anyclass IsoValue++type Ty8 (f :: Type -> Type -> Type) a = f a Dt6+type Ty9 (f :: Type -> Type -> Type) a = Ty8 f a+type Ty10 (f :: Type -> Type -> Type) a = Ty9 f a++data ExampleTypeAliasMany = ExampleTypeAliasMany+  { _etamField1 :: Ty1+  , _etamField2 :: Ty2 Integer MText+  , _etamField3 :: Ty3 Integer+  , _etamField4 :: Ty4+  , _etamField5 :: Ty5 Integer+  , _etamField6 :: Ty6 MText+  , _etamField7 :: Ty7 Dt5+  , _etamField8 :: Ty10 Dt7 Dt8+  , _etamField9 :: Dt4 Integer+  }+  deriving stock Generic+  deriving anyclass IsoValue++-- Check that the declarations generated by `deriveManyRPC` actually compile.+deriveManyRPC "ExampleTypeAliasMany" []++unit_Can_derive_many_instances_with_type_aliases :: Assertion+unit_Can_derive_many_instances_with_type_aliases = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleTypeAliasMany" [] >>= TH.lift)+    [d|+      data ExampleTypeAliasManyRPC = ExampleTypeAliasManyRPC+        { _etamField1RPC :: AsRPC Ty1+        , _etamField2RPC :: AsRPC (Ty2 Integer MText)+        , _etamField3RPC :: AsRPC (Ty3 Integer)+        , _etamField4RPC :: AsRPC Ty4+        , _etamField5RPC :: AsRPC (Ty5 Integer)+        , _etamField6RPC :: AsRPC (Ty6 MText)+        , _etamField7RPC :: AsRPC (Ty7 Dt5)+        , _etamField8RPC :: AsRPC (Ty10 Dt7 Dt8)+        , _etamField9RPC :: AsRPC (Dt4 Integer)+        }+      instance HasRPCRepr ExampleTypeAliasMany where+        type AsRPC ExampleTypeAliasMany = ExampleTypeAliasManyRPC+      deriving anyclass instance IsoValue ExampleTypeAliasManyRPC++      -- An instance is generated for Dt1+      data Dt1RPC = Dt1RPC (AsRPC Integer)+      instance HasRPCRepr Dt1 where+        type AsRPC Dt1 = Dt1RPC+      deriving anyclass instance IsoValue Dt1RPC++      -- An instance is generated for Dt2+      data Dt2RPC a = Dt2RPC (AsRPC a)+      instance HasRPCRepr a => HasRPCRepr (Dt2 a) where+        type AsRPC (Dt2 a) = Dt2RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt2RPC a)++      -- An instance is generated for Dt3+      data Dt3RPC k v = Dt3RPC (AsRPC k) (AsRPC v)+      instance (HasRPCRepr k, HasRPCRepr v) => HasRPCRepr (Dt3 k v) where+        type AsRPC (Dt3 k v) = Dt3RPC k v+      deriving anyclass instance (IsoValue (AsRPC k), IsoValue (AsRPC v)) => IsoValue (Dt3RPC k v)++      -- An instance is generated for Dt5+      data Dt5RPC a = Dt5RPC (AsRPC a)+      instance HasRPCRepr a => HasRPCRepr (Dt5 a) where+        type AsRPC (Dt5 a) = Dt5RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt5RPC a)++      -- An instance is generated for Dt6+      data Dt6RPC = Dt6RPC (AsRPC Integer)+      instance HasRPCRepr Dt6 where+        type AsRPC Dt6 = Dt6RPC+      deriving anyclass instance IsoValue Dt6RPC++      -- An instance is generated for Dt7+      data Dt7RPC a b = Dt7RPC (AsRPC a) (AsRPC b)+      instance (HasRPCRepr a, HasRPCRepr b) => HasRPCRepr (Dt7 a b) where+        type AsRPC (Dt7 a b) = Dt7RPC a b+      deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (Dt7RPC a b)++      -- An instance is generated for Dt8+      data Dt8RPC = Dt8RPC (AsRPC ([BigMap Integer MText]))+      instance HasRPCRepr Dt8 where+        type AsRPC Dt8 = Dt8RPC+      deriving anyclass instance IsoValue Dt8RPC++      -- An instance is generated for Dt4+      data Dt4RPC v = Dt4RPC (AsRPC (Ty6 v))+      instance HasRPCRepr (Ty6 v) => HasRPCRepr (Dt4 v) where+        type AsRPC (Dt4 v) = Dt4RPC v+      deriving anyclass instance IsoValue (AsRPC (Ty6 v)) => IsoValue (Dt4RPC v)+    |]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Doc.Position   ( test_DifferentPosition

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'. module Test.Entrypoints@@ -15,7 +14,7 @@ import Prelude hiding (or)  import Data.Default (def)-import qualified Data.Map as Map+import Data.Map qualified as Map import Fmt (pretty) import Test.HUnit (assertBool, (@?=)) import Test.Hspec (shouldSatisfy)@@ -26,13 +25,13 @@ import Hedgehog.Gen.Tezos.Address (genAddress) import Morley.Michelson.Parser (uparamTypeQ, utypeQ) import Morley.Michelson.TypeCheck (HST(..))-import qualified Morley.Michelson.TypeCheck as TC+import Morley.Michelson.TypeCheck qualified as TC import Morley.Michelson.Typed-import Morley.Michelson.Untyped (noAnn, unsafeBuildEpName)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped (buildEpName, noAnn)+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Cleveland.Instances ()-import Test.Cleveland.Util (fromHex, runGen, unsafeFromHex)+import Test.Cleveland.Util (fromHex, runGen)  import Test.Util.Hedgehog @@ -58,7 +57,7 @@      unitParamType :: TC.SomeParamType     unitParamType =-      either (error . pretty) id $+      unsafe $       TC.mkSomeParamType (U.ParameterType U.tyunit noAnn)  test_EpAddress :: [TestTree]@@ -66,7 +65,7 @@   [ testGroup "Parsing" $     [ testCase "Simple entrypoint" $         parseEpAddress (formatAddress addr <> "%ab")-          @?= Right (EpAddress addr (unsafeBuildEpName "ab"))+          @?= Right (EpAddress addr (unsafe . buildEpName $ "ab"))      , testCase "No entrypoint" $         parseEpAddress (formatAddress addr)@@ -74,7 +73,7 @@      , testCase "Weird entrypoint" $         parseEpAddress (formatAddress addr <> "%a%b")-          @?= Right (EpAddress addr (unsafeBuildEpName "a%b"))+          @?= Right (EpAddress addr (unsafe . buildEpName $ "a%b"))     ]    , testGroup "parse . format = pure"@@ -86,11 +85,11 @@ test_ParseEpAddressRaw :: [TestTree] test_ParseEpAddressRaw = mconcat   [ [ testCase ("Successfully encodes " <> toString b)-      (formatEpAddress (unsafeParseEpAddressRaw (unsafeFromHex b)) @?= a)+      (formatEpAddress ((unsafe . parseEpAddressRaw) (unsafe $ fromHex b)) @?= a)     | (a, b) <- sampleEpAddresses     ]   , [ testCase ("Fails to parse invalid address " <> toString a)-      ((fromHex a >>= rightToMaybe . parseEpAddressRaw) `shouldSatisfy` isNothing)+      ((fromHex a >>= first pretty . parseEpAddressRaw) `shouldSatisfy` isLeft)     | a <- invalidRawEpAddresses     ]   ]@@ -100,10 +99,10 @@   [ testGroup "Duplications are handled" $     [ testCase "One duplicated entrypoint" $         mkParamNotes (or "a" "a" prim prim) noAnn-          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| []))+          @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| []))     , testCase "Several duplicated entrypoint" $         mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn-          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [unsafeBuildEpName "b"]))+          @?= Left (ParamEpDuplicatedNames (unsafe (buildEpName "a") :| [unsafe . buildEpName $ "b"]))     , testCase "Duplicated default entrypoint" $         mkParamNotes (or "default" "default" prim prim) noAnn           @?= Left (ParamEpDuplicatedNames (DefEpName :| []))@@ -133,7 +132,7 @@ test_ParamEpError =   [ testGroup "Buildable instance"     [ testCase "Duplicated entrypoints error" $-        pretty @_ @Text (ParamEpDuplicatedNames $ unsafeBuildEpName "a" :| [DefEpName])+        pretty @_ @Text (ParamEpDuplicatedNames $ unsafe (buildEpName "a") :| [DefEpName])         @?= "Duplicated entrypoint names: 'a', '<default>'"     , testCase "Uncallable arms error" $         pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight])@@ -145,16 +144,16 @@ test_contractHasEntrypoints :: [TestTree] test_contractHasEntrypoints =   [ testCase "Simple parameter" $-      U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) |]+      U.mkEntrypointsMap [uparamTypeQ| or (int %a) (nat %b) |]         @?= Map.fromList         [ (UnsafeEpName "a", [utypeQ| int |])         , (UnsafeEpName "b", [utypeQ| nat |])         ]    , testCase "Root entrypoint is considered" $-      U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) %root |]+      U.mkEntrypointsMap [uparamTypeQ| or %root (int %a) (nat %b) |]         @?= Map.fromList-        [ (UnsafeEpName "root", [utypeQ| (int %a | nat %b) |])+        [ (UnsafeEpName "root", [utypeQ| or (int %a) (nat %b) |])         , (UnsafeEpName "a", [utypeQ| int |])         , (UnsafeEpName "b", [utypeQ| nat |])         ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Ext   ( test_PRINT_and_TEST_ASSERT@@ -11,32 +10,73 @@ import Fmt (pretty) import Test.HUnit (Assertion, assertFailure) import Test.Hspec.Expectations (shouldSatisfy)-import Test.Tasty (TestTree)+import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase)  import Morley.Michelson.Interpret (MorleyLogs(..), interpret) import Morley.Michelson.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter) import Morley.Michelson.TypeCheck-  (HST(..), SomeHST(..), TypeCheckMode(..), runTypeCheck, throwingTCError, typeCheckExt,-  typeCheckInstr, typeCheckingWith, unsafeMkSomeParamType, unsafeWithWTP)-import Morley.Michelson.Typed (epcPrimitive, pattern AsUType)-import qualified Morley.Michelson.Typed as T+  (HST(..), SomeHST(..), TypeCheckMode(..), mkSomeParamType, runTypeCheck, throwingTCError,+  typeCheckExt, typeCheckInstr, typeCheckingWith, unsafeWithWTP)+import Morley.Michelson.Typed (epcPrimitive, pattern (:#), pattern AsUType)+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped   (ExpandedExtInstr, ExtInstrAbstract(..), ParameterType(..), StackTypePattern(..), T(..), Ty(..),   TyVar(..), noAnn)+import Morley.Util.PeanoNatural (PeanoNatural(..)) import Test.Cleveland.Instances ()-import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract)-import Test.Util.Contracts -test_PRINT_and_TEST_ASSERT :: IO [TestTree]-test_PRINT_and_TEST_ASSERT = concatTestTrees-  [ testTreesWithTypedContract (inContractsDir "testassert_square.mtz") $-    testAssertSquareImpl-  , testTreesWithTypedContract (inContractsDir "testassert_square2.mtz") $-    testAssertSquareImpl+testassert_square :: T.Contract ('T.TPair 'T.TInt 'T.TInt) 'T.TUnit+testassert_square = T.defaultContract $+  T.CAR :#+  T.UNPAIR :#+  T.Ext (T.TEST_ASSERT+    (T.TestAssert "CheckSides"+      (T.PrintComment [Left "Sides are ", Right (T.StackRef Zero), Left " x ", Right (T.StackRef One)])+      ( T.DUP :#+        T.GT :#+        T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT) :#+        T.DIPN Two (T.DUP :# T.GT :# T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT)) :#+        T.AND :# T.AND :# T.AND+      )+    )) :#+  T.MUL :#+  T.Ext (T.PRINT $ T.PrintComment [Left "Area is ", Right $ T.StackRef Zero]) :#+  T.DROP :#+  T.UNIT :#+  T.NIL @'T.TOperation :#+  T.PAIR++-- | This is like 'testassert_square', but test_assert is executed on stack+-- with more than one element.+testassert_square2 :: T.Contract ('T.TPair 'T.TInt 'T.TInt) 'T.TUnit+testassert_square2 = T.defaultContract $+  T.CAR :#+  T.DIP T.UNIT :#+  T.UNPAIR :#+  T.Ext (T.TEST_ASSERT+    (T.TestAssert "CheckSides"+      (T.PrintComment [Left "Sides are ", Right (T.StackRef Zero), Left " x ", Right (T.StackRef One)])+      ( T.DUP :#+        T.GT :#+        T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT) :#+        T.DIPN Two (T.DUP :# T.GT :# T.DIP (T.PUSH (T.VInt 101) :# T.COMPARE :# T.GT)) :#+        T.AND :# T.AND :# T.AND+      )+    )) :#+  T.MUL :#+  T.Ext (T.PRINT $ T.PrintComment [Left "Area is ", Right $ T.StackRef Zero]) :#+  T.DROP :#+  T.NIL @'T.TOperation :#+  T.PAIR++test_PRINT_and_TEST_ASSERT :: [TestTree]+test_PRINT_and_TEST_ASSERT =+  [ testGroup "testassert_square" $ testAssertSquareImpl testassert_square+  , testGroup "testassert_square2" $ testAssertSquareImpl testassert_square2   ]   where-    testAssertSquareImpl c = pure+    testAssertSquareImpl c =       [ testCase "TEST_ASSERT assertion passed" $ do         runTest True c 100 100         runTest True c 1 1@@ -103,7 +143,7 @@     nh (ni, si) =       typeCheckingWith def $       runTypeCheck (TypeCheckContract $-                      unsafeMkSomeParamType $+                      unsafe . mkSomeParamType $                       ParameterType (Ty TKey noAnn) noAnn)                    (usingReaderT def $                       throwingTCError $@@ -112,5 +152,5 @@     runExtTest :: (ExpandedExtInstr, SomeHST) -> Bool -> Assertion     runExtTest (ui, SomeHST hst) correct = case (nh (ui, hst), correct) of       (Right _, False) -> assertFailure $ "Test expected to fail but it passed"-      (Left e, True)   -> assertFailure $ "Test expected to pass but it failed with error: " <> show e+      (Left e, True)   -> assertFailure $ "Test expected to pass but it failed with error: " <> pretty e       _                -> pass

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE QuasiQuotes #-} @@ -24,7 +23,7 @@ import Morley.Michelson.ErrorPos (InstrCallStack(..), srcPos) import Morley.Michelson.Parser (codeSrc) import Morley.Michelson.Typed-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Util.Interpolate import Test.Cleveland hiding (importContract, importUntypedContract) import Test.Cleveland.Instances ()

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for integrational testing machinery. module Test.Integrational

@@ -1,7 +1,9 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ {-# OPTIONS_GHC -Wno-orphans #-}  module Test.Interpreter@@ -9,7 +11,7 @@   , test_increment   , test_fail   , test_mutez_add_overflow-  , test_mutez_sub_overflow+  , test_mutez_sub_underflow   , test_basic1   , test_lsl   , test_lsr@@ -29,34 +31,29 @@   , test_fail_callstack   ) where -import Fmt (Buildable(..), (+|), (|+))+import Fmt ((+|), (|+)) import Hedgehog (forAll, property)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) -import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage, NiceUnpackedValue)+import Lorentz (HasEntrypointArg, NiceParameter, NiceParameterFull, NiceStorage) import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), srcPos) import Morley.Michelson.Text import Morley.Michelson.Typed (IsoValue(..), divMich, modMich)-import qualified Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Crypto import Test.Cleveland import Test.Cleveland.Internal.Abstract (TransferFailure(..), TransferFailureReason(..))-import Test.Cleveland.Michelson-  (concatTestTrees, testTreesWithTypedContract, testTreesWithUntypedContract)+import Test.Cleveland.Michelson (concatTestTrees, testTreesWithTypedContract)+import Test.Cleveland.Michelson.Import+  (testTreesWithTypedContractExt, testTreesWithUntypedContractExt)  import Test.Util.Contracts -instance Buildable ByteString where-  build = show--instance Buildable Tuple1 where-  build = show- catchTransferFailureReason :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailureReason catchTransferFailureReason = fmap tfReason . catchTransferFailure @@ -67,7 +64,6 @@     , HasEntrypointArg cp (EntrypointRef 'Nothing) cp     , AsRPC st ~ st     , NiceParameterFull cp, NiceStorage st-    , NiceUnpackedValue (AsRPC st)     )   => AliasHint -> T.Contract (ToT cp) (ToT st) -> cp -> st -> m st callSimple nm contract cp st = do@@ -124,14 +120,11 @@           _ -> failure "expecting another failure reason"   ] -test_mutez_sub_overflow :: IO [TestTree]-test_mutez_sub_overflow =+test_mutez_sub_underflow :: IO [TestTree]+test_mutez_sub_underflow =   testTreesWithTypedContract (contractsDir </> "mutez_sub_underflow.tz") $ \contract -> pure   [ testScenarioOnEmulator "Mutez sub underflow test" $ scenario $       callSimple "mutez_sub_underflow" contract () ()-        & catchTransferFailureReason >>= \case-          MutezArithError T.SubUnderflow -> pass-          x -> failure $ "expecting another failure reason, got " +| x |+ ""   ]  test_basic1 :: IO [TestTree]@@ -200,7 +193,7 @@  test_fail_callstack :: IO [TestTree] test_fail_callstack =-  testTreesWithUntypedContract (contractsDir </> "fail_in_let.mtz") $ \contract -> pure+  testTreesWithUntypedContractExt (contractsDir </> "fail_in_let.mtz") $ \contract -> pure   [ testScenarioOnEmulator "Should correctly report FAIL instruction position" $ scenario do       callUntyped "fail_in_let" contract True () & catchTransferFailureReason >>= \case           FailedWith _ (Just ics) ->@@ -225,7 +218,7 @@  test_Sum_types :: IO [TestTree] test_Sum_types = concatTestTrees-  [ testTreesWithUntypedContract (contractsDir </> "union.mtz") $ \contract -> pure+  [ testTreesWithUntypedContractExt (contractsDir </> "union.mtz") $ \contract -> pure     [ testGroup "union.mtz: union corresponds to Haskell types properly" $         let caseTest param = scenario $ callUntyped "union" contract param ()         in@@ -236,7 +229,7 @@         , testScenarioOnEmulator "Case 5" $ caseTest (Case5 ["q"])         ]     ]-  , testTreesWithUntypedContract (contractsDir </> "case.mtz") $ \contract -> pure+  , testTreesWithUntypedContractExt (contractsDir </> "case.mtz") $ \contract -> pure     [ testGroup "CASE instruction" $         let caseTest param expectedStorage = scenario $               callUntyped "case" contract param ("" :: MText)@@ -249,7 +242,7 @@         , testScenarioOnEmulator "Case 5" $ caseTest (Case5 $ ["a", "b"]) "ab"         ]     ]-  , testTreesWithTypedContract (contractsDir </> "tag.mtz") $ \contract -> pure+  , testTreesWithTypedContractExt (contractsDir </> "tag.mtz") $ \contract -> pure     [ testScenarioOnEmulator "TAG instruction" $ scenario $         let expected = mconcat ["unit" :: MText, "o" :: MText, "ab" :: MText, "nat" :: MText, "int" :: MText]         in callSimple "tag" contract () ("" :: MText) @@== expected@@ -258,17 +251,17 @@  test_Product_types :: IO [TestTree] test_Product_types = concatTestTrees-  [ testTreesWithTypedContract (contractsDir </> "access.mtz") $ \contract -> pure+  [ testTreesWithTypedContractExt (contractsDir </> "access.mtz") $ \contract -> pure     [ testScenarioOnEmulator "ACCESS instruction" $ scenario $         callSimple @Tuple1 "access" contract (1, "a", Just "a", Right "a", ["a"]) ()     ]-  , testTreesWithTypedContract (contractsDir </> "set.mtz") $ \contract -> pure+  , testTreesWithTypedContractExt (contractsDir </> "set.mtz") $ \contract -> pure     [ testScenarioOnEmulator "SET instruction" $ scenario $       let expected = (2, "za", Just "wa", Right "ya", ["ab"]) :: Tuple1       in callSimple @_ @Tuple1 "set" contract () (1, "a", Just "a", Right "a", ["a", "b"])           @@== expected     ]-  , testTreesWithTypedContract (contractsDir </> "construct.mtz") $ \contract -> pure+  , testTreesWithTypedContractExt (contractsDir </> "construct.mtz") $ \contract -> pure     [ testScenarioOnEmulator "CONSTRUCT instruction" $ scenario $       let expected = (1, "a", Just "b", Left "q", []) :: Tuple1       in callSimple @_ @Tuple1 "construct" contract () (0, "", Nothing, Right "", []) @@== expected

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Interpreter.Annotations   ( test_cast_notes@@ -23,12 +22,14 @@   , test_special_annotations   ) where +import Debug qualified (show) import Prelude hiding (Const)+import Unsafe qualified  import Control.Lens (ix, makeLensesFor, (<<%=)) import Control.Monad.RWS.Strict (RWST, runRWST)-import qualified Data.List as List-import Data.Map.Strict as Map+import Data.List qualified as List+import Data.Map.Strict qualified as Map import Data.Vinyl (Rec(..)) import Data.Vinyl.Functor (Const(..)) import Data.Vinyl.Recursive (recordToList, rmap)@@ -41,20 +42,19 @@   (ContractEnv, InstrRunner, InterpreterState(..), InterpreterStateMonad(..),   MichelsonFailureWithStack(..), MorleyLogsBuilder, StkEl(..), initInterpreterState, mkInitStack,   runInstrImpl, starNotesStkEl)+import Morley.Michelson.Parser (notes) import Morley.Michelson.Runtime.Dummy (dummyBigMapCounter, dummyContractEnv, dummyGlobalCounter) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed (Notes(..), Operation, Value'(..), starNotes, starParamNotes, toVal)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped (noAnn)-import qualified Morley.Michelson.Untyped as U-import Morley.Tezos.Address (Address, unsafeParseAddress)-import Morley.Tezos.Core (toMutez)+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Address (Address, parseAddress) import Morley.Util.Sing (eqParamSing) import Test.Cleveland.Instances () import Test.Cleveland.Michelson (importContract)-import qualified Text.Show-import qualified Unsafe+import Text.Show qualified  import Test.Util.Contracts (contractsDir, (</>)) @@ -72,7 +72,7 @@ instance Show SomeStack where   show (SomeStack v) = case v of     RNil -> "[]"-    x :& xs -> show x <> " :& " <> show (SomeStack xs)+    x :& xs -> Debug.show x <> " :& " <> Debug.show (SomeStack xs)  instance Eq SomeStack where   a == b = stackToElems a == stackToElems b@@ -102,10 +102,10 @@  type TestInstrRunner = InstrRunner (ExceptT MichelsonFailureWithStack $ RWST ContractEnv MorleyLogsBuilder TestInterpreterState IO) -runInstrTest :: TestInstrRunner+runInstrTest :: HasCallStack => TestInstrRunner runInstrTest = runInstrTestImpl False -runInstrTestImpl :: Bool -> TestInstrRunner+runInstrTestImpl :: HasCallStack => Bool -> TestInstrRunner runInstrTestImpl skipInstr instr stack = do   actualStack <- runInstrImpl (runInstrTestImpl $ isAnnotated instr) instr stack   when (isRealInstr instr && not skipInstr) do@@ -144,7 +144,8 @@   _ -> True  stackAnnotationsTest-  :: String+  :: HasCallStack+  => String   -> Rec StkEl (T.ContractInp cp st)   -> [Maybe SomeStack]   -> T.Contract cp st@@ -154,7 +155,8 @@     stackAnnotationsAssertion initialStack expectedStacks contract  stackAnnotationsAssertion-  :: Rec StkEl (T.ContractInp cp st)+  :: HasCallStack+  => Rec StkEl (T.ContractInp cp st)   -> [Maybe SomeStack]   -> T.Contract cp st   -> Assertion@@ -217,14 +219,14 @@   ]   where     y :: T.Notes 'T.TInt-    y = T.NTInt "y"+    y = [notes|int :y|]      param = "parameter"      expectedStacksIF_NONE_None :: [Maybe SomeStack]     expectedStacksIF_NONE_None =       [ -- CAR-        someStack $ StkEl (T.VOption @'T.TInt Nothing) param (T.NTOption U.noAnn y) :& RNil+        someStack $ StkEl (T.VOption @'T.TInt Nothing) param [notes|option (int :y)|] :& RNil         -- PUSH (int :y) 0       , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil         -- IF_NONE@@ -237,7 +239,7 @@     expectedStacksIF_NONE_Some :: [Maybe SomeStack]     expectedStacksIF_NONE_Some =       [ -- CAR-        someStack $ StkEl (T.VOption $ Just $ T.VInt 6) param (T.NTOption U.noAnn y) :& RNil+        someStack $ StkEl (T.VOption $ Just $ T.VInt 6) param [notes|option (int :y)|] :& RNil         -- PUSH (int :y) 1       , someStack $ StkEl (T.VInt 1) U.noAnn y :& StkEl (T.VInt 6) param y :& RNil         -- ADD@@ -252,7 +254,7 @@     expectedStacksIF_LEFT_Left :: [Maybe SomeStack]     expectedStacksIF_LEFT_Left =       [ -- CAR-        someStack $ StkEl (T.VOr @'T.TInt $ Left $ T.VInt 6) param (T.NTOr U.noAnn U.noAnn U.noAnn y y) :& RNil+        someStack $ StkEl (T.VOr @'T.TInt $ Left $ T.VInt 6) param [notes|or (int :y) (int :y)|] :& RNil         -- PUSH (int :y) 1       , someStack $ StkEl (T.VInt 1) U.noAnn y :& StkEl (T.VInt 6) param y :& RNil         -- ADD@@ -267,7 +269,7 @@     expectedStacksIF_LEFT_Right :: [Maybe SomeStack]     expectedStacksIF_LEFT_Right =       [ -- CAR-        someStack $ StkEl (T.VOr @'T.TInt $ Right $ T.VInt 7) param (T.NTOr U.noAnn U.noAnn U.noAnn y y) :& RNil+        someStack $ StkEl (T.VOr @'T.TInt $ Right $ T.VInt 7) param [notes|or (int :y) (int :y)|] :& RNil         -- PUSH (int :y) 2       , someStack $ StkEl (T.VInt 2) U.noAnn y :& StkEl (T.VInt 7) param y :& RNil         -- ADD@@ -282,7 +284,7 @@     expectedStacksIF_CONS_Cons :: [Maybe SomeStack]     expectedStacksIF_CONS_Cons =       [ -- CAR-        someStack $ StkEl (T.VList [T.VInt 10]) param (T.NTList U.noAnn y) :& RNil+        someStack $ StkEl (T.VList [T.VInt 10]) param [notes|list (int :y)|] :& RNil         -- DROP       , someStack $ RNil         -- DIP@@ -299,7 +301,7 @@     expectedStacksIF_CONS_Nil :: [Maybe SomeStack]     expectedStacksIF_CONS_Nil =       [ -- CAR-        someStack $ StkEl (T.VList @'T.TInt []) param (T.NTList U.noAnn y) :& RNil+        someStack $ StkEl (T.VList @'T.TInt []) param [notes|list (int :y)|] :& RNil         -- PUSH (int :y) 0       , someStack $ StkEl (T.VInt 0) U.noAnn y :& RNil         -- IF_CONS@@ -319,8 +321,7 @@   ]   where     notesPair :: T.Notes ('T.TPair 'T.TInt 'T.TInt)-    notesPair =-      T.NTPair "q" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "x") (T.NTInt "y")+    notesPair = [notes|pair :q (int :x) (int :y)|]      pair :: T.Value ('T.TPair 'T.TInt 'T.TInt)     pair = T.VPair (T.VInt 1, T.VInt 2)@@ -333,7 +334,7 @@       , someStack $ StkEl         pair         "ab"-        (T.NTPair "p" U.noAnn U.noAnn U.noAnn U.noAnn (T.NTInt "a") (T.NTInt "b")) :& RNil+        [notes|pair :p (int :a) (int :b)|] :& RNil         -- CAST (pair int int)       , someStack $ StkEl pair "ab" T.starNotes :& RNil         -- CAST @xy (pair (int :x) (int :y))@@ -359,7 +360,7 @@   ]   where     q :: T.Notes 'T.TInt-    q = T.NTInt "q"+    q = [notes|int :q|]      qv :: U.VarAnn     qv = "q"@@ -412,17 +413,11 @@       ]      y :: T.Notes 'T.TInt-    y = T.NTInt "y"+    y = [notes|int :y|]      yv :: U.VarAnn     yv = "y" -    list :: T.Notes ('T.TList 'T.TInt)-    list = T.NTList "list" T.starNotes--    listv :: U.VarAnn-    listv = "list"-     expectedStacksMap :: [Maybe SomeStack]     expectedStacksMap =       [ -- DROP@@ -430,7 +425,7 @@         -- PUSH @y (int :y) 42       , someStack $ StkEl (T.VInt 42) yv y :& RNil         -- PUSH @list (list :l int) {1; 10}-      , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) listv list :& StkEl (T.VInt 42) yv y :& RNil+      , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) "list" [notes|list :list int|] :& StkEl (T.VInt 42) yv y :& RNil         -- CAST @q (int :q)       , someStack $ StkEl (T.VInt 1) qv q :& StkEl (T.VInt 42) yv y :& RNil         -- CAST int@@ -444,7 +439,7 @@         -- DIP       , someStack $ StkEl (T.VInt 10) qv q :& StkEl (T.VInt 42) yv T.starNotes :& RNil         -- MAP-      , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) U.noAnn (T.NTList U.noAnn q) :& StkEl (T.VInt 42) yv T.starNotes :& RNil+      , someStack $ StkEl (T.VList [T.VInt 1, T.VInt 10]) U.noAnn [notes|list (int :q)|] :& StkEl (T.VInt 42) yv T.starNotes :& RNil         -- DROP       , someStack $ StkEl (T.VInt 42) yv T.starNotes :& RNil         -- NIL operation@@ -463,13 +458,13 @@   ]   where     m :: T.Notes ('T.TMap 'T.TInt 'T.TInt)-    m = T.NTMap "m" k (T.NTInt "v")+    m = [notes|map :m (int :k) (int :v)|]      k :: T.Notes 'T.TInt-    k = T.NTInt "k"+    k = [notes|int :k|]      v :: T.Notes ('T.TOption 'T.TInt)-    v = T.NTOption U.noAnn $ T.NTInt "v"+    v = [notes|option (int :v)|]      mv, kv, vv :: U.VarAnn     mv = "m"@@ -510,7 +505,7 @@   ]   where     address :: Address-    address = unsafeParseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD"+    address = unsafe $ parseAddress "KT1Cb7mVHmedj3Q1vfXvaiRqeNDMqpLbMKjD"      storage :: T.Value 'T.TAddress     storage = T.VAddress $ T.EpAddress address T.DefEpName@@ -519,13 +514,13 @@     op = T.VOption Nothing      mutez :: T.Value 'T.TMutez-    mutez = T.VMutez $ toMutez 100+    mutez = T.VMutez 100      contract :: T.Value 'T.TOperation     contract = T.VOp $ T.OpCreateContract T.CreateContract       { T.ccOriginator = genesisAddress       , T.ccDelegate = Nothing-      , T.ccBalance = toMutez 100+      , T.ccBalance = 100       , T.ccStorageVal = T.VUnit       , T.ccContract = T.defaultContract $         let loc c = T.WithLoc $ InstrCallStack [] $ srcPos 12 c in@@ -565,19 +560,9 @@     expectedStacks     contract   where-    pairNotes =-      NTPair noAnn-        "aa" noAnn-        noAnn noAnn-        (NTInt "a")-        (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c"))+    pairNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] -    pairNotes' =-      NTPair noAnn-      noAnn noAnn-      noAnn noAnn-      (NTInt "a")-      (NTPair noAnn noAnn noAnn noAnn noAnn (NTInt "b") (NTInt "c"))+    pairNotes' = [notes|pair (int :a) (int :b) (int :c)|]      paramN = "parameter" @@ -598,9 +583,9 @@           RNil         -- UNPAIR 3       , someStack $-          StkEl (toVal @Integer 4) "aa" (NTInt "a") :&-          StkEl (toVal @Integer 5) "bb" (NTInt "b") :&-          StkEl (toVal @Integer 6) "cc" (NTInt "c") :&+          StkEl (toVal @Integer 4) "aa" [notes|int :a|] :&+          StkEl (toVal @Integer 5) "bb" [notes|int :b|] :&+          StkEl (toVal @Integer 6) "cc" [notes|int :c|] :&           RNil         -- PAIR @newStorage 3;       , someStack $@@ -628,15 +613,9 @@     expectedStacks     contract   where-    paramNotes =-      NTPair noAnn-        "aa" noAnn-        noAnn noAnn-        (NTInt "a")-        (NTPair noAnn "bb" "cc" noAnn noAnn (NTInt "b") (NTInt "c"))+    paramNotes = [notes|pair (int :a %aa) (int :b %bb) (int :c %cc)|] -    storageNotes =-      NTPair noAnn "aa" "bb" noAnn noAnn (NTInt "a") (NTInt "b")+    storageNotes = [notes|pair (int :a %aa) (int :b %bb)|]      storage = (5, 6) :: (Integer, Integer)     param = (1, (2, 3)) :: (Integer, (Integer, Integer))@@ -658,18 +637,18 @@           RNil         -- GET 3;       , someStack $-          StkEl (toVal @Integer 2) noAnn (NTInt "b") :&+          StkEl (toVal @Integer 2) noAnn [notes|int :b|] :&           StkEl (toVal param) "parameter" paramNotes :&           RNil         -- SWAP;       , someStack $           StkEl (toVal param) "parameter" paramNotes :&-          StkEl (toVal @Integer 2) noAnn (NTInt "b") :&+          StkEl (toVal @Integer 2) noAnn [notes|int :b|] :&           RNil         -- GET @aa 1       , someStack $-          StkEl (toVal @Integer 1) "aa" (NTInt "a") :&-          StkEl (toVal @Integer 2) noAnn (NTInt "b") :&+          StkEl (toVal @Integer 1) "aa" [notes|int :a|] :&+          StkEl (toVal @Integer 2) noAnn [notes|int :b|] :&           RNil         -- PAIR 2         -- NIL operation;@@ -691,11 +670,11 @@         ignoreStack         -- PUSH @var (int :i) 1       , someStack $-          StkEl (toVal @Integer 1) "var" (NTInt "i") :&+          StkEl (toVal @Integer 1) "var" [notes|int :i|] :&           RNil         -- GET 0;       , someStack $-          StkEl (toVal @Integer 1) noAnn (NTInt "i") :&+          StkEl (toVal @Integer 1) noAnn [notes|int :i|] :&           RNil         -- NIL operation;         -- PAIR 2;@@ -714,12 +693,12 @@     expectedStacks =       [ -- DROP         ignoreStack-        -- PUSH (pair (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) (Pair 0 "a" Unit);+        -- PUSH (pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3)) { 0; "a"; Unit };       , someStack $           StkEl             (toVal (0 :: Integer, ("a" :: MText, ())))             noAnn-            (NTPair "t0" "f1" "" "" "" (NTInt "t1") (NTPair "" "f2" "f3" "" "" (NTString "t2") (NTUnit "t3"))) :&+            [notes|(pair :t0 (int :t1 %f1) (string :t2 %f2) (unit :t3 %f3))|] :&           RNil          -- PUSH (nat :t4) 0; UPDATE 1;@@ -732,7 +711,7 @@           StkEl             (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural)))             noAnn-            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f2" "f3" "" "" (NTNat "t5") (NTNat "t6"))) :&+            [notes|(pair :t0 (nat :t4 %f1) (nat :t5 %f2) (nat :t6 %f3))|] :&           RNil          -- PUSH (pair (nat :t7 %f7) (nat :t8 %f8)) (Pair 0 0);@@ -742,7 +721,7 @@           StkEl             (toVal (0 :: Natural, (0 :: Natural, 0 :: Natural)))             noAnn-            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTPair "" "f7" "f8" "" "" (NTNat "t7") (NTNat "t8"))) :&+            [notes|pair :t0 (nat :t4 %f1) (nat :t7 %f7) (nat :t8 %f8)|] :&           RNil          -- PUSH (nat :t9) 0;@@ -752,7 +731,7 @@           StkEl             (toVal (0 :: Natural, 0 :: Natural))             noAnn-            (NTPair "t0" "f1" "" "" "" (NTNat "t4") (NTNat "t9")) :&+            [notes|pair :t0 (nat :t4 %f1) (nat :t9)|] :&           RNil         -- NIL operation; PAIR;       , ignoreStack, ignoreStack@@ -811,16 +790,16 @@          -- GET_AND_UPDATE       , someStack $-          StkEl (toVal (Nothing :: Maybe Natural))          "varVal" (NTOption "" (NTNat "v")) :&-          StkEl (toVal (one (1, 1) :: Map Integer Natural)) "varMap" (NTMap "map" (NTInt "k") (NTNat "v")) :&+          StkEl (toVal (Nothing :: Maybe Natural))          "varVal" [notes|option (nat :v)|] :&+          StkEl (toVal (one (1, 1) :: Map Integer Natural)) "varMap" [notes|map :map (int :k) (nat :v)|] :&           RNil          -- PUSH @varKey (int :k) 1;         -- GET_AND_UPDATE @newVarMap;       , ignoreStack       , someStack $-          StkEl (toVal (Just 1 :: Maybe Natural))       "varVal"    (NTOption "" (NTNat "v")) :&-          StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" (NTMap "map" (NTInt "k") (NTNat "v")) :&+          StkEl (toVal (Just 1 :: Maybe Natural))       "varVal"    [notes|option (nat :v)|] :&+          StkEl (toVal (mempty :: Map Integer Natural)) "newVarMap" [notes|map :map (int :k) (nat :v)|] :&           RNil          -- DROP 2;@@ -832,14 +811,14 @@ test_dupn = importContract (contractsDir </> "dup-n.tz") <&>   stackAnnotationsTest     "Check that annotations behave as intended with DUP n (#471)"-    (StkEl (T.VPair (T.VUnit, store)) noAnn (NTPair noAnn noAnn noAnn noAnn noAnn starNotes x) :& RNil)+    (StkEl (T.VPair (T.VUnit, store)) noAnn [notes|pair unit (int :x)|] :& RNil)     expectedStacks   where     store :: T.Value 'T.TInt     store = T.VInt 42      x :: T.Notes 'T.TInt-    x = T.NTInt "x"+    x = [notes|int :x|]      kek :: T.Value 'T.TString     kek = T.VString "kek"@@ -929,7 +908,7 @@     contract   where     param = (1, 2, ()) :: (Natural, Natural, ())-    paramNotes = NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTPair noAnn noAnn noAnn noAnn noAnn starNotes (NTUnit "last"))+    paramNotes = [notes|pair nat nat (unit :last)|]      expectedStacks :: [Maybe SomeStack]     expectedStacks =@@ -958,9 +937,9 @@         -- DROP       , ignoreStack         -- GET @kek 4-      , someStack $ StkEl VUnit "kek" (NTUnit "last") :& RNil+      , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil         -- CDR @kek 2 (macro expanded above)-      , someStack $ StkEl VUnit "kek" (NTUnit "last") :& RNil+      , someStack $ StkEl VUnit "kek" [notes|unit :last|] :& RNil         -- NIL operation       , ignoreStack         -- PAIR@@ -1065,9 +1044,9 @@     expectedStacksRIGHTSpecial :: [Maybe SomeStack]     expectedStacksRIGHTSpecial =       [ -- CAR-        someStack $ StkEl (VUnit) "p.y" (NTUnit noAnn) :& RNil+        someStack $ StkEl (VUnit) "p.y" starNotes :& RNil         -- RIGHT % %@ never-      , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" (NTOr noAnn noAnn "y" (NTNever "") (NTUnit "")) :& RNil+      , someStack $ StkEl (VOr @'T.TNever $ Right $ VUnit) "p" [notes|or never (unit %y)|] :& RNil         -- DROP         -- PUSH unit Unit         -- NUL operation

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-orphans #-} @@ -12,11 +11,10 @@  import Test.Tasty (TestTree) -import Fmt (Buildable(..)) import Morley.Michelson.Typed-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Test.Cleveland-import Test.Cleveland.Util (unsafeFromHex)+import Test.Cleveland.Util (fromHex)  import Test.Util.Contracts @@ -40,13 +38,10 @@   partApplyContract <-     importUntypedContract $ inContractsDir "partially-applied-lambda-packed.tz"   handle <- originateUntypedSimple "apply" (U.ValueBytes $ U.InternalByteString "") partApplyContract-  let expected = unsafeFromHex "05020000000f0743035b0005034202000000020316"+  let expected = unsafe $ fromHex "05020000000f0743035b0005034202000000020316"   transfer TransferData     { tdTo = handle     , tdAmount = 0     , tdEntrypoint = DefEpName     , tdParameter = () }   getStorage @ByteString handle @@== expected--instance Buildable ByteString where-  build = show

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Module, containing spec to test auction.tz contract. --@@ -10,15 +9,15 @@   ) where  import Hedgehog (forAll, property, withTests)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty)  import Hedgehog.Gen.Tezos.Core (genMutez', genTimestamp, midTimestamp) import Hedgehog.Gen.Tezos.Crypto (genKeyHash) import Morley.Tezos.Address (Address(..))-import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, toMutez, unMutez, unsafeMkMutez)+import Morley.Tezos.Core (Mutez, Timestamp, timestampPlusSeconds) import Morley.Tezos.Crypto (KeyHash, hashKey) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract)@@ -37,7 +36,7 @@ test_Auction =   [ testScenarioOnEmulator "Bid after end of auction triggers failure" $ withInitialNow midTimestamp     $ scenario do-      let initState = (aBitBeforeMidTimestamp, (toMutez 1000, keyHash1))+      let initState = (aBitBeforeMidTimestamp, (1000, keyHash1))       handle <- originateSimple @Param @Storage "auction" initState contract       transfer TransferData         { tdTo = handle@@ -88,9 +87,8 @@     -- ^ 1s before NOW      denseTime = timestampPlusSeconds midTimestamp <$> Gen.enum -4 4-    denseAmount = unsafeMkMutez <$> Gen.word64 (Range.constant (midAmount' - 4) (midAmount' + 4))+    denseAmount = genMutez' $ Range.constant (midAmount - 4) (midAmount + 4)     midAmount = maxMutez `div` 2-    midAmount' = unMutez midAmount     genMutez'' = genMutez' $ Range.constant 0 maxMutez     maxMutez = maxBound `div` 100 @@ -130,7 +128,7 @@   = assert (isLeft resE)       "Failure didn't trigger on attempt to bid with amount <= than previous bid"   | Left e <- resE-      = failure $ "Unexpected script fail: " <> show e+      = failure $ "Unexpected script fail: " <> fromString (displayException e)    | Right (endOfAuction', _) <- resE   , endOfAuction /= endOfAuction'@@ -144,6 +142,5 @@   , keyHash' /= newKeyHash       = failure $ "Storage updated to wrong value: new key hash"                       <> " is not equal to contract's parameter"-   | Right _ <- resE      = getBalance addr @@== amount

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Interpreter.Balance   ( test_balanceIncludesAmount@@ -8,12 +7,12 @@   ) where  import Hedgehog (Gen, forAll, property, withTests)-import qualified Hedgehog.Gen as Gen+import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty)  import Morley.Michelson.Typed-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core import Test.Cleveland import Test.Cleveland.Michelson (testTreesWithUntypedContract)@@ -28,8 +27,8 @@  genFixture :: Gen Fixture genFixture = do-  fStartingBalance <- toMutez <$> Gen.enum 1000 5000-  fAmount <- toMutez <$> Gen.enum 0 1000+  fStartingBalance <- Gen.enum 1000 5000+  fAmount <- Gen.enum 0 1000   return Fixture{..}  test_balanceIncludesAmount :: IO [TestTree]@@ -77,14 +76,14 @@             let               origDataA = UntypedOriginateData                 { uodName = "balance_test_case_a"-                , uodBalance = (toMutez 0)+                , uodBalance = 0                 , uodStorage = (untypeValue $ toVal @[Mutez] [])                 , uodContract = contractA                 }             let               origDataB = UntypedOriginateData                 { uodName = "balance_test_case_b"-                , uodBalance = (toMutez 0)+                , uodBalance = 0                 , uodStorage = (untypeValue $ toVal ())                 , uodContract = contractB                 }@@ -93,7 +92,7 @@             let               transferData = TransferData                 { tdTo = addressA-                , tdAmount = toMutez 100+                , tdAmount = 100                 , tdEntrypoint = DefEpName                 , tdParameter = addressB                 }@@ -102,6 +101,6 @@              -- A sends 30 to B, then B sends 5 back to A. A records call to BALANCE at each entry.             -- We expect that 5 mutez sent back are included in the second call to BALANCE.-            let expectedStorage = [toMutez 75, toMutez 100]+            let expectedStorage = [75, 100]             getStorage @[Mutez] addressA @@== expectedStorage         ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for the contract that calls self several times. @@ -11,16 +10,16 @@   ) where  import Hedgehog (forAll, property, withTests)-import qualified Hedgehog.Gen as Gen+import Hedgehog.Gen qualified as Gen import Test.HUnit (Assertion, (@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) import Test.Tasty.Hedgehog (testProperty)-import qualified Unsafe (fromIntegral)+import Unsafe qualified (fromIntegral)  import Morley.Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Test.Cleveland import Test.Cleveland.Michelson (ContractPropValidator, contractProp) import Test.Cleveland.Michelson.Dummy

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Interpreter.CallSelfAddress   ( test_Call_self_address

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.ComparableSet@@ -9,8 +8,8 @@  import Data.Set as Set (fromList, toList) import Hedgehog (forAll, property, withTests)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.Compare@@ -13,13 +12,12 @@ import Test.Tasty.Hedgehog (testProperty)  import Hedgehog.Gen.Michelson.Typed-import qualified Hedgehog.Gen.Michelson.Untyped as U+import Hedgehog.Gen.Michelson.Untyped qualified as U import Hedgehog.Gen.Tezos.Core (genMutez) import Morley.Michelson.Interpret (ContractReturn)-import Morley.Michelson.TypeCheck.Types (getWTP') import Morley.Michelson.Typed (ToT, fromVal)-import qualified Morley.Michelson.Typed as T-import Morley.Tezos.Core (Mutez, toMutez)+import Morley.Michelson.Typed qualified as T+import Morley.Tezos.Core (Mutez) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract) import Test.Cleveland.Util (failedTest, genTuple2)@@ -32,7 +30,7 @@ -- | Spec to test compare.tz contract. test_compare :: [TestTree] test_compare =-    [ testScenarioOnEmulator "success test" $ myScenario (toMutez 10, toMutez 11)+    [ testScenarioOnEmulator "success test" $ myScenario (10, 11)     , testProperty "Random check" $         withTests 200 $ property $ do           inputParam <- forAll $ genTuple2 genMutez genMutez@@ -79,7 +77,7 @@   testProperty "Eq and Ord instances on Value match" $     withDiscards 200 $ property $ do       T.AsUTypeExt st _ <- forAll U.genValidType-      case (T.checkComparability st, T.checkOpPresence st, getWTP' st) of+      case (T.checkComparability st, T.checkOpPresence st, T.getWTP' st) of         (T.CanBeCompared, T.OpAbsent, Right T.Dict) -> do           value1 <- forAll $ genValue' st           value2 <- forAll $ genValue' st

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Module, containing spec to test compare.tz contract. module Test.Interpreter.ComparePairs@@ -12,7 +11,7 @@ import Test.Tasty.Hedgehog (testProperty)  import Hedgehog.Gen.Tezos.Core (genMutez)-import Morley.Tezos.Core (Mutez, toMutez)+import Morley.Tezos.Core (Mutez) import Test.Cleveland import Test.Cleveland.Lorentz.Import (embedContract) import Test.Cleveland.Util (genTuple2)@@ -25,8 +24,8 @@ test_compare_pairs :: [TestTree] test_compare_pairs =     [ testScenarioOnEmulator "success test" $ myScenario-          ( (toMutez 10, toMutez 11)-          , (toMutez 10, toMutez 12)+          ( (10, 11)+          , (10, 12)           )     , testProperty "Random check" $         withTests 200 $ property $ do

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# OPTIONS_GHC -Wno-orphans #-} @@ -10,8 +9,8 @@   ) where  import Hedgehog (forAll, property)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) 

@@ -1,12 +1,12 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Module, containing spec to test contract_op.tz contract. module Test.Interpreter.ContractOp   ( test_contract_op   ) where +import Fmt (pretty) import Test.Tasty (TestTree)  import Morley.Michelson.Untyped@@ -64,7 +64,7 @@       }      msg isGood paramType =-      "parameter in environment is '" <> show paramType <> "', " <>+      "parameter in environment is '" <> pretty paramType <> "', " <>       bool "" "but "  isGood <> "contract expects '%root int :q'"      intQ   = ParameterType $ Ty TInt "q"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'create_2_n_reverse_ops.tz' contract. @@ -34,4 +33,4 @@     stString @== "kek"  someAddr :: Address-someAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"+someAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'create_n_transfer.tz' contract. See [#643] module Test.Interpreter.CreateAndTransfer@@ -26,4 +25,4 @@  -- Address hardcoded in 'create_n_transfer.tz'. constAddr :: Address-constAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"+constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for the 'environment.tz' contract @@ -9,14 +8,14 @@   ) where  import Hedgehog (Gen, forAll, property, withTests)-import qualified Hedgehog.Gen as Gen+import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty)  import Morley.Michelson.Runtime.GState import Morley.Michelson.Typed-import qualified Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core import Test.Cleveland import Test.Cleveland.Michelson.Import (embedContract)@@ -43,8 +42,8 @@ genFixture :: Gen Fixture genFixture = do   fPassOriginatedAddress <- Gen.bool-  fBalance <- toMutez <$> Gen.enum 1 1234-  fAmount <- toMutez <$> Gen.enum 1 42+  fBalance <- Gen.enum 1 1234+  fAmount <- Gen.enum 1 42   return Fixture {..}  testImpl@@ -86,13 +85,13 @@         let           balanceAfterTransfer = fBalance fixture `unsafeAddMutez` fAmount fixture         if-          | balanceAfterTransfer > toMutez 1000 ->+          | balanceAfterTransfer > 1000 ->               expectFailedWith balanceAfterTransfer $                 transfer transferData           | fPassOriginatedAddress fixture ->               expectFailedWith environmentAddress $                 transfer transferData-          | fAmount fixture < toMutez 15 ->+          | fAmount fixture < 15 ->               expectFailedWith (fAmount fixture) $                 transfer transferData           | otherwise -> transfer transferData

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for the @PRINT@ extended command @@ -15,7 +14,7 @@  import Morley.Michelson.Interpret (MorleyLogs(..)) import Morley.Michelson.Text (MText)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Tezos.Address (Address) import Test.Cleveland

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Interpreter.Reference   ( test_InterpreterWithReferenceImplementation@@ -17,26 +16,25 @@ import Test.Tasty.Hedgehog (testProperty)  import Hedgehog.Gen.Michelson.Typed (genValue)+import Morley.AsRPC (AsRPC, MaybeRPC(..), TAsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client (RunError(..), runMorleyClientM) import Morley.Client.RPC (RunCodeErrors(..))-import Morley.Client.RPC.AsRPC (AsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client.Util as Reference (RunContractParameters(..), runContract) import Morley.Michelson.Interpret   (InterpretError(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) import Morley.Michelson.Runtime as Morley import Morley.Michelson.Runtime.GState (genesisAddress)-import Morley.Michelson.TypeCheck (TypeCheckOptions(..), withWTPm)+import Morley.Michelson.TypeCheck (TypeCheckOptions(..)) import Morley.Michelson.Typed-  (Contract, Contract'(..), EpAddress(..), SingT(..), SomeContract(..), SomeStorage(..), Value,-  Value'(..), dfsMapValue)+  (Contract, Contract'(..), EpAddress(..), SingT(..), SomeConstrainedValue(..), SomeContract(..),+  SomeStorage, Value, Value'(..), dfsMapValue) import Morley.Michelson.Typed.Arith (ArithError(..), MutezArithErrorType(..)) import Morley.Michelson.Typed.Convert import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address-import Morley.Tezos.Core-  (Timestamp(..), dummyChainId, getCurrentTime, toMutez, unsafeMkMutez, zeroMutez)+import Morley.Tezos.Core (Timestamp(..), dummyChainId, getCurrentTime, zeroMutez) import Morley.Tezos.Crypto import Morley.Util.Named import Morley.Util.Sing (eqI)@@ -93,6 +91,11 @@       -- ↑ We cannot predict the actual block level in a real chain.       -- There is another @../../contracts/level.tz@ contract that checks that we can interpret       -- the @LEVEL@ instruction, without checking its result.+      , "../../contracts/sapling_annot.tz"+      , "../../contracts/sapling_transaction.tz"+      , "../../contracts/tezos_examples/opcodes/sapling_empty_state.tz"+      -- ↑ Sapling types and instructions are supported for typechecking only and not the actual+      -- implementation.      ]  test_Regression688 :: IO TestTree@@ -130,14 +133,10 @@       -- inputs.       testProperty ("compare result with morley interpreter for " <> file) $         withTests 4 $ property $ do-          -- TODO [#392]: this check have to become unnecessary-          withWTPm @st $ do-            withWTPm @cp $ do--              parameter <- forAll $ genValue @cp-              storage <- forAll $ genValue @st+          parameter <- forAll $ genValue @cp+          storage <- forAll $ genValue @st -              compareWithReference withEnv file contract parameter storage+          compareWithReference withEnv file contract parameter storage  compareWithReference   :: forall cp st. (ParameterScope cp, StorageScope st)@@ -151,9 +150,9 @@           runMorleyClientM (neMorleyClientEnv env) $             Reference.runContract @cp @st RunContractParameters               { rcpContract = contract-              , rcpParameter = parameter-              , rcpStorage = storage-              , rcpBalance = unsafeMkMutez 4000000000000+              , rcpParameter = NotRPC parameter+              , rcpStorage = NotRPC storage+              , rcpBalance = 4000000000000               , rcpAmount = zeroMutez               , rcpSender = Just genesisAddress               , rcpSource = Just genesisAddress@@ -161,9 +160,9 @@         currentTimestamp <- getCurrentTime         -- Reference implementation sends 0,05 tz to implicit contract for this contract         let amount = if file == "../../contracts/tezos_examples/opcodes/proxy.tz"-                    then toMutez 50000 else minBound+                    then 50000 else minBound         resMorley <- try @_ @ExecutorError $ silence $-          Morley.runContract (Just currentTimestamp) (Just 0) 100500 (unsafeMkMutez 4000000000000) ""+          Morley.runContract (Just currentTimestamp) (Just 0) 100500 4000000000000 ""           tcOptions (untypeValue storage) (convertContract contract)           (TxData genesisAddress (TxUntypedParam $ untypeValue parameter) U.DefEpName amount)           (#verbose :! False)@@ -218,11 +217,11 @@ -- We also don't check big_map contents or their IDs. -- -- TODO [#604]: compare big_maps' contents.-compareValues :: forall st m. (HasCallStack, MonadTest m, SingI st) => Value (AsRPC st) -> Value st -> m ()+compareValues :: forall st m. (HasCallStack, MonadTest m, SingI st) => Value (TAsRPC st) -> Value st -> m () compareValues storageReference storageMorley =   preprocessValue storageReference === preprocessValue (valueAsRPC storageMorley)   where-    preprocessValue :: Value (AsRPC st) -> Value (AsRPC st)+    preprocessValue :: Value (TAsRPC st) -> Value (TAsRPC st)     preprocessValue = dfsMapValue placeStubs . scrubBigMapIDs (sing @st)      placeStubs :: Value t -> Value t@@ -237,7 +236,7 @@     --     -- The morley interpreter and the RPC might assign different IDs to each big_map,     -- so we need to scrub all IDs before checking whether the two storages are equivalent.-    scrubBigMapIDs :: forall t. Sing t -> Value (AsRPC t) -> Value (AsRPC t)+    scrubBigMapIDs :: forall t. Sing t -> Value (TAsRPC t) -> Value (TAsRPC t)     scrubBigMapIDs storageSing storage =       case (storageSing, storage) of         (STBigMap{}, VNat _) -> VNat 0@@ -285,13 +284,6 @@             ScriptOverflow -> True             _ -> False         ) $ "Morley interpreter failed with mutez multiplication overflow, \-            \however reference interpreter failed with:\n" <> displayException rpcErr-      MutezArithError SubUnderflow _ _ ->-        assertRpcErrs errs-        (\case-            MutezSubtractionUnderflow {} -> True-            _ -> False-        ) $ "Morley interpreter failed with mutez subtraction underflow, \             \however reference interpreter failed with:\n" <> displayException rpcErr     MichelsonGasExhaustion ->       assertRpcErrs errs

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'create_n_transfer.tz' contract. See [#643] module Test.Interpreter.SetDelegate

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Interpreter tests involving 'StackRef'. 

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for the 'string_caller.tz' contract and its interaction with -- the 'fail_or_store_and_transfer.tz' contract. Both of them have comments describing

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'transfer_n_create.tz' contract. See [#643] module Test.Interpreter.TransferAndCreate@@ -30,4 +29,4 @@  -- Address hardcoded in 'transfer_n_create.tz'. constAddr :: Address-constAddr = unsafeParseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"+constAddr = unsafe $ parseAddress "tz1NJRjyBXqAmBf94FLTTuQWZGHpmGG4CWKe"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on on-chain views. module Test.Interpreter.Views@@ -53,7 +52,7 @@   ]   where     checkContract-      :: (NiceStorage st, NicePackedValue st, Eq st, Buildable st, AsRPC st ~ st)+      :: (NiceStorage st, Eq st, Buildable st, AsRPC st ~ st)       => String -> st -> st -> TestTree     checkContract fileName initSt expected =       testScenario fileName $ scenario $ clarifyErrors ("For '" +| fileName |+ "'") do

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Macro   ( unit_PAPAIR@@ -15,9 +14,9 @@   ) where  import Hedgehog (forAll, property, (===))-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Gen.Michelson.Untyped as Gen.U-import qualified Hedgehog.Range as Range+import Hedgehog.Gen qualified as Gen+import Hedgehog.Gen.Michelson.Untyped qualified as Gen.U+import Hedgehog.Range qualified as Range import Test.Hspec (Expectation, shouldBe) import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty)@@ -25,7 +24,7 @@ import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), SrcPos, srcPos) import Morley.Michelson.Macro import Morley.Michelson.Untyped-  (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), noAnn, unsafeMkAnnotation)+  (ExpandedOp(..), InstrAbstract(..), Value, Value'(..), mkAnnotation, noAnn)  import Test.Cleveland.Instances () @@ -153,10 +152,10 @@   mapPairLeaves annotations (P pair pair) `shouldBe`     P (P (leaf "field1") (leaf "field2")) (P (leaf "field3") (F n))   where-    annotations = unsafeMkAnnotation <$> ["field1", "field2", "field3"]+    annotations = unsafe . mkAnnotation <$> ["field1", "field2", "field3"]     n = noAnn     f = "field"-    leaf f' = F (unsafeMkAnnotation f')+    leaf f' = F (unsafe . mkAnnotation $ f')     pair = P (F n) (F n)  unit_expand :: Expectation

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Michelson.Parser.Value   ( test_exponentialBacktracking@@ -18,7 +17,7 @@ test_exponentialBacktracking :: TestTree test_exponentialBacktracking = localOption (mkTimeout $ 500 * millisec) $   testCase "Parser is able to parse nested pairs in reasonable time" do-    let parsedValue = P.parseNoEnv P.value "" "Pair 0 (Pair 1 (Pair 2 (Pair 3 \+    let parsedValue = P.parseNoEnv @() P.value "" "Pair 0 (Pair 1 (Pair 2 (Pair 3 \           \(Pair 4 (Pair 5 (Pair 6 (Pair 7 (Pair 8 (Pair 9 (Pair 10 (Pair 11 \           \(Pair 12 (Pair 13 (Pair 14 (Pair 15 16)))))))))))))))"         expected = foldr1 ValuePair $ ValueInt <$> 0 :| [1..16]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for "Morley.Michelson.Runtime". @@ -25,10 +24,9 @@ import Morley.Michelson.Runtime.GState (BigMapCounter, GState(..), initGState) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) import Morley.Tezos.Address-import Morley.Tezos.Core (toMutez) import Test.Cleveland.Instances ()  test_executorPure :: IO [TestTree]@@ -67,7 +65,7 @@       { tdSenderAddress = ceSender ce       , tdParameter = TxTypedParam $ caParameter ca       , tdEntrypoint = DefEpName-      , tdAmount = toMutez 100+      , tdAmount = 100       }    runExecutorM dummyNow dummyLevel dummyMaxSteps initGState $ do@@ -128,7 +126,7 @@         { tdSenderAddress = detGenKeyAddress "transferFromUnknown"         , tdParameter = TxTypedParam $ caParameter ca         , tdEntrypoint = DefEpName-        , tdAmount = toMutez 0+        , tdAmount = 0         }  ----------------------------------------------------------------------------

@@ -0,0 +1,102 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Tests of `Show` and `RenderDoc` instances of Michelson types.+module Test.Michelson.Show+  ( unit_AnnTagsShow+  , unit_AnnTagsRenderDoc+  , unit_AnnotationSetShow+  , unit_AnnotationSetRenderDoc+  , unit_NotesShow+  , unit_NotesRenderDoc+  , unit_InstrAbstractShow+  , unit_InstrAbstractRenderDoc+  ) where++import Debug qualified (show)++import Test.HUnit (Assertion, assertEqual)++import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc)+import Morley.Michelson.Typed (Notes(..), T(..))+import Morley.Michelson.Untyped qualified as U++render :: RenderDoc a => a -> LText+render = printDoc True . renderDoc doesntNeedParens++-- * Annotation++typeAnn :: U.TypeAnn+typeAnn = U.UnsafeAnnotation @U.TypeTag "type"++fieldAnn :: U.FieldAnn+fieldAnn = U.UnsafeAnnotation @U.FieldTag "field"++varAnn :: U.VarAnn+varAnn = U.UnsafeAnnotation @U.VarTag "var"++unit_AnnTagsShow :: Assertion+unit_AnnTagsShow =+  zipWithM_ (assertEqual @Text "Annotations' `show` produces type tags")+    [Debug.show typeAnn, Debug.show fieldAnn, Debug.show varAnn]+    [ "UnsafeAnnotation @TypeTag \"type\""+    , "UnsafeAnnotation @FieldTag \"field\""+    , "UnsafeAnnotation @VarTag \"var\""+    ]++unit_AnnTagsRenderDoc :: Assertion+unit_AnnTagsRenderDoc =+  zipWithM_ (assertEqual "Annotations' `renderDoc` produces Michelson annotations")+    [render typeAnn, render fieldAnn, render varAnn]+    [":type", "%field", "@var"]++-- * AnnotationSet++annSet :: U.AnnotationSet+annSet = U.AnnotationSet [typeAnn] [fieldAnn] [varAnn]++unit_AnnotationSetShow :: Assertion+unit_AnnotationSetShow =+  assertEqual @Text "AnnotationSet's `show` is stock"+    (Debug.show annSet)+    "AnnotationSet {asTypes = [UnsafeAnnotation @TypeTag \"type\"], asFields = [UnsafeAnnotation @FieldTag \"field\"], asVars = [UnsafeAnnotation @VarTag \"var\"]}"++unit_AnnotationSetRenderDoc :: Assertion+unit_AnnotationSetRenderDoc =+  assertEqual "AnnotationSet's `renderDoc` produces a list of annotations"+    (render annSet)+    ":type %field @var"++-- * Notes++pair :: Notes ('TPair 'TUnit 'TUnit)+pair = NTPair typeAnn fieldAnn U.noAnn varAnn U.noAnn (NTUnit U.noAnn) (NTUnit U.noAnn)++unit_NotesShow :: Assertion+unit_NotesShow =+  assertEqual @Text "Notes' `show` is stock"+    (Debug.show pair)+    "NTPair (UnsafeAnnotation @TypeTag \"type\") (UnsafeAnnotation @FieldTag \"field\") (UnsafeAnnotation @FieldTag \"\") (UnsafeAnnotation @VarTag \"var\") (UnsafeAnnotation @VarTag \"\") (NTUnit (UnsafeAnnotation @TypeTag \"\")) (NTUnit (UnsafeAnnotation @TypeTag \"\"))"++unit_NotesRenderDoc :: Assertion+unit_NotesRenderDoc =+  assertEqual "Notes' `renderDoc` produces a Michelson annotated type"+    (render pair)+    "pair :type (unit %field @var) unit"++-- * InstrAbstract++instr :: U.InstrAbstract U.ExpandedOp+instr = U.PAIR typeAnn varAnn fieldAnn U.noAnn++unit_InstrAbstractShow :: Assertion+unit_InstrAbstractShow =+  assertEqual @Text "InstrAbstract's `show` is stock"+    (Debug.show instr)+    "PAIR (UnsafeAnnotation @TypeTag \"type\") (UnsafeAnnotation @VarTag \"var\") (UnsafeAnnotation @FieldTag \"field\") (UnsafeAnnotation @FieldTag \"\")"++unit_InstrAbstractRenderDoc :: Assertion+unit_InstrAbstractRenderDoc =+  assertEqual "InstrAbstract's `renderDoc` produces an annotated Michelson instruction"+    (render instr)+    "PAIR :type %field @var"

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on 'MText'. module Test.Michelson.Text@@ -12,15 +11,15 @@   , unit_mt   ) where -import Fmt (pretty)+import Fmt (Buildable, pretty) import Test.HUnit (Assertion, (@?), (@?=)) import Test.Tasty (TestTree)-import qualified Text.Megaparsec as P+import Text.Megaparsec qualified as P  import Hedgehog.Gen.Michelson (genMText) import Morley.Michelson.Parser import Morley.Michelson.Text-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Util.Text (dquotes) import Test.Cleveland.Instances () @@ -30,7 +29,7 @@ parseMTextTest :: HasCallStack => Text -> Either () MText parseMTextTest t =   first (const ()) $-  expectString <$> parseNoEnv (stringLiteral <* P.eof) codeSrc (dquotes t)+  expectString <$> parseNoEnv @() (stringLiteral <* P.eof) codeSrc (dquotes t)   where     expectString = \case       U.ValueString t' -> t'@@ -42,10 +41,10 @@   [ roundtripTree genMText writeMText parseMTextTest ]  -- | Check value against the given predicate.-(@??) :: (Show a, HasCallStack) => a -> (a -> Bool) -> Assertion+(@??) :: (Buildable a, HasCallStack) => a -> (a -> Bool) -> Assertion (@??) val predicate =   predicate val @?-  ("Predicate does not hold for value " <> show val)+  ("Predicate does not hold for value " <> pretty val)  unit_mkMText :: Assertion unit_mkMText = do

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2022 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Michelson.Typed.AnnotatedValue   ( unit_variant_read@@ -13,11 +12,12 @@   )   where -import Control.Lens+import Control.Lens (_Just, each, ix, (+~), (<>~), (^@..)) import Fmt (Buildable, GenericBuildable(..)) import Test.Cleveland.Instances ()-import Test.Tasty.HUnit+import Test.Tasty.HUnit ((@?=)) +import Morley.Michelson.Parser (notes) import Morley.Michelson.Text (MText) import Morley.Michelson.Typed.AnnotatedValue import Morley.Michelson.Typed.Annotation (Notes(..), starNotes)@@ -45,13 +45,18 @@  paramNotes :: Notes (ToT Param) paramNotes =-  NTOr "" "" ""-    (NTOr "" "p1" "p2" starNotes starNotes)-    (NTOr "" "p3" "p4" starNotes nestedParamNotes)+  [notes|+    or+      (or (int %p1)+          (string %p2)+      )+      (or (pair %p3 string nat)+          (or %p4 (int %p1) (nat %p2))+      )+  |]  nestedParamNotes :: Notes (ToT NestedParam)-nestedParamNotes =-  NTOr "" "p1" "p2" starNotes starNotes+nestedParamNotes = [notes|or (int %p1) (nat %p2)|]  unit_variant_read :: IO () unit_variant_read = do@@ -134,13 +139,23 @@  storageNotes :: Notes (ToT Storage) storageNotes =-  NTPair "" "" "" "" ""-    (NTPair "" "field1" "field2" "" "" starNotes starNotes)-    (NTPair "" "field3" "field4" "" "" starNotes nestedNotes)+  [notes|+    pair+      (pair+        (int %field1)+        (pair %field2 string nat)+      )+      (pair+        (option %field3 int)+        (pair %field4+          (string %field1)+          (int %field2)+        )+      )+  |]  nestedNotes :: Notes (ToT Nested)-nestedNotes =-  NTPair "" "field1" "field2" "" "" starNotes starNotes+nestedNotes = [notes|pair (string %field1) (int %field2)|]  storage :: Storage storage = Storage@@ -196,11 +211,11 @@ unit_nodes = do   storageSav ^@.. nodes @?=     [ ("", SomeAnnotatedValue-          (NTPair "" "field1" "field2" "" "" starNotes starNotes)+          [notes|pair (int %field1) (pair %field2 string nat)|]           (toVal @(Integer, (MText, Natural)) $ (1, ("a", 2)))       )     , ("", SomeAnnotatedValue-          (NTPair "" "field3" "field4" "" "" starNotes (NTPair "" "field1" "field2" "" "" starNotes starNotes) )+          [notes|pair (option %field3 int) (pair %field4 (string %field1) (int %field2))|]           (toVal @(Maybe Integer, (MText, Integer)) $ (Just 3, ("b", 4)))       )     , ("field1", SomeAnnotatedValue starNotes (toVal $ sField1 storage))@@ -233,9 +248,12 @@  collectionsNotes :: Notes (ToT Collections) collectionsNotes =-  NTPair "" "listField" "" "" ""-    starNotes-    (NTPair "" "mapField" "bigMapField" "" "" starNotes starNotes)+  [notes|+    pair+      (list %listField int)+      (map %mapField string nat)+      (big_map %bigMapField string nat)+  |]  collectionsSav :: SomeAnnotatedValue collectionsSav =

@@ -1,24 +1,26 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on 'Convert'. module Test.Michelson.Typed.Convert   ( test_sub+  , test_sub_mutez   , test_sha   , test_arith+  , test_wrappers   ) where -import Test.HUnit (assertEqual)+import Data.Vinyl.Core (Rec(..))+import Test.HUnit (assertEqual, (@?=)) import Test.Hspec ()-import Test.Tasty (TestTree)+import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Convert (instrToOps) import Morley.Michelson.Typed.Instr (Instr(..))-import qualified Morley.Michelson.Typed.Instr as T (Instr(EQ, GE, GT, LE, LT, NEQ)) import Morley.Michelson.Typed.Value (Value'(..))-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Test.Cleveland.Instances ()  annA, annB :: U.Annotation a@@ -37,6 +39,18 @@       , U.PrimEx $ U.SUB annA       ] +test_sub_mutez :: TestTree+test_sub_mutez =+  testCase "SUB_MUTEZ accepts one annotation" $+    assertEqual "SUB_MUTEZ accepts one annotation" (instrToOps sub) subExpected+  where+    sub = PUSH (VMutez 9) `Seq` PUSH (VMutez 8) `Seq` InstrWithVarNotes (annA :| []) SUB_MUTEZ+    subExpected =+      [ U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TMutez U.noAnn) (U.ValueInt 9)+      , U.PrimEx $ U.PUSH U.noAnn (U.Ty U.TMutez U.noAnn) (U.ValueInt 8)+      , U.PrimEx $ U.SUB_MUTEZ annA+      ]+ test_sha :: TestTree test_sha =   testCase "SHA256 and SHA512 accept one annotation" $ do@@ -73,3 +87,15 @@      arithTOps = [T.EQ, T.NEQ, T.LT, T.GT, T.LE, T.GE]     arithUOps = [U.EQ, U.NEQ, U.LT, U.GT, U.LE, U.GE]++test_wrappers :: TestTree+test_wrappers = testGroup "instruction wrappers interact sensibly"+  [ testCase "Meta under notes" do+      instrToOps+        (T.InstrWithNotes (Proxy @'[]) (T.NTUnit [U.annQ|meq|] :& RNil) $+          T.InstrWithVarNotes (one [U.annQ|kek|]) $+            T.Meta (T.SomeMeta ()) $+              T.UNIT+        )+        @?= [U.PrimEx $ U.UNIT [U.annQ|meq|] [U.annQ|kek|]]+  ]

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'Morley.Michelson.Typed.Util'. @@ -9,8 +8,10 @@   , hprop_linearizeLeft_performance   , unit_dfsInstr_counter   , unit_dfsInstr_meta+  , unit_dfsInstr_ctorEffectsApp   ) where +import Control.Monad.Writer.Strict (Writer, runWriter, tell, writer) import Data.Default (def) import Data.Typeable (cast) @@ -46,9 +47,8 @@   dfsFoldInstr (settings False) step instr @?= Sum 2   where     settings goToValues =-      DfsSettings+      def       { dsGoToValues = goToValues-      , dsCtorEffectsApp = ceaBottomToTop       }      step :: Instr a b -> Sum Word@@ -63,7 +63,7 @@  unit_dfsInstr_meta :: Assertion unit_dfsInstr_meta = do-  let (output, prod) = dfsInstr def go input+  let (output, prod) = runWriter $ dfsTraverseInstr def go input   -- We don't have an untyped version of Meta, so let's pattern match instead of   -- checking for equality.   case output of@@ -87,7 +87,44 @@             (Meta (SomeMeta str) (Meta (SomeMeta (4 :: Word)) nilOp))               (Meta (SomeMeta (5 :: Word)) PAIR)))) -    go :: Instr i o -> (Instr i o, Product Word)+    go :: Instr i o -> Writer (Product Word) (Instr i o)     go = \case-      Meta (SomeMeta m) i | Just (v :: Word) <- cast m -> (i, Product v)-      i -> (i, mempty)+      Meta (SomeMeta m) i | Just (v :: Word) <- cast m -> i <$ tell (Product v)+      i -> pure i++unit_dfsInstr_ctorEffectsApp :: Assertion+unit_dfsInstr_ctorEffectsApp = do+  -- simple case+  dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp1 } step instr1+    @?= Product (2 * (2 + 3) * 5)++  -- ctor effects are applied to primitives+  dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp2 } step instr1+    @?= Product ((2 + 1) * (2 + 1) * (1 + 2) * 5)++  -- ctor effects are applied to intermediate nodes+  dfsFoldInstr def{ dsCtorEffectsApp = ctorEffectsApp1 } step instr2+    @?= Product (2 * (1 + 2 * (1 + 2)))+  where+    step :: Instr i o -> Product Int+    step = \case+      UNIT -> Product 2+      PUSH _ -> Product 5+      _ -> mempty++    ctorEffectsApp1 = CtorEffectsApp "custom adds for wrappers" \oldInstr ->+      let addition = case oldInstr of+            Nested{} -> 1+            DIP{} -> 3+            _ -> 0+      in writer . second (\(Product x) -> Product (x + addition)) . runWriter++    ctorEffectsApp2 = CtorEffectsApp "custom adds for leaves" \oldInstr ->+      let addition = case oldInstr of+            UNIT{} -> 1+            DROP{} -> 2+            _ -> 0+      in writer . second (\(Product x) -> Product (x + addition)) . runWriter++    instr1 = UNIT `Seq` DUP `Seq` DIP UNIT `Seq` DROP `Seq` PUSH VUnit+    instr2 = UNIT `Seq` Nested (DROP `Seq` UNIT `Seq` Nested (DROP `Seq` UNIT))

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests on 'Value'. module Test.Michelson.Typed.Value

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'Morley.Micheline.Expression'. @@ -13,16 +12,17 @@   , test_toExpression   ) where +import Unsafe qualified (fromJust)+ import Data.Aeson   (FromJSON, Result(Error, Success), ToJSON(toJSON), Value(String), eitherDecode, encode, fromJSON,   object, (.=)) import Data.Aeson.QQ (aesonQQ) import Data.Default (def)-import qualified Data.Map as Map-import Data.Maybe (fromJust)-import qualified Data.Set as Set+import Data.Map qualified as Map+import Data.Set qualified as Set import Data.Singletons (demote)-import qualified Data.Text as T+import Data.Text qualified as T import Hedgehog (Gen) import Test.Hspec.Expectations (shouldBe) import Test.Tasty (TestTree, testGroup)@@ -30,14 +30,15 @@  import Hedgehog.Gen.Michelson.Typed (genSimpleInstr, genValueInt, genValueMutez, genValueUnit) import Hedgehog.Gen.Michelson.Untyped (genValidType)-import qualified Hedgehog.Gen.Morley.Micheline as M-import qualified Morley.Micheline as M+import Hedgehog.Gen.Morley.Micheline qualified as M+import Morley.Micheline qualified as M+import Morley.Michelson.Parser (notes) import Morley.Michelson.Text (MText)-import qualified Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core (Mutez) import Test.Cleveland.Instances ()-import Test.Cleveland.Util (unsafeFromHex)+import Test.Cleveland.Util (fromHex) import Test.Util.Hedgehog (roundtripTree)  testJSON@@ -379,7 +380,7 @@   , testCase "Converting VContract to Expression" $       M.toExpression @(T.Value $ 'T.TContract 'T.TAddress)         (getSampleValue @('T.TContract 'T.TAddress)) `shouldBe`-          M.ExpressionBytes (unsafeFromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")+          M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")    , testCase "Converting VBigMap to Expression" $       M.toExpression @(T.Value $ 'T.TBigMap (T.ToT Integer) (T.ToT Integer))@@ -411,7 +412,7 @@    , testCase "Converting VKey to Expression" $       M.toExpression @(T.Value 'T.TKey) (getSampleValue @('T.TKey)) `shouldBe`-       M.ExpressionBytes (unsafeFromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082")+       M.ExpressionBytes (unsafe $ fromHex "00aad3f16293766169f7db278c5e0e9db4fb82ffe1cbcc35258059617dc0fec082")    , testCase "Converting VTimestamp to Expression" $       M.toExpression @(T.Value 'T.TTimestamp) (getSampleValue @('T.TTimestamp)) `shouldBe`@@ -419,25 +420,25 @@    , testCase "Converting VAddress to Expression" $       M.toExpression @(T.Value 'T.TAddress) (getSampleValue @('T.TAddress)) `shouldBe`-        M.ExpressionBytes (unsafeFromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")+        M.ExpressionBytes (unsafe $ fromHex "01122d038abd69be91b4b6803f2f098a088e259e7200")    , testCase "Converting VChainId to Expression" $       M.toExpression @(T.Value 'T.TChainId) (getSampleValue @('T.TChainId)) `shouldBe`-        M.ExpressionBytes (unsafeFromHex "458aa837")+        M.ExpressionBytes (unsafe $ fromHex "458aa837")    , testCase "Converting VSignature to Expression" $       M.toExpression @(T.Value 'T.TSignature) (getSampleValue @('T.TSignature)) `shouldBe`-        (M.ExpressionBytes $ unsafeFromHex+        (M.ExpressionBytes $ unsafe $ fromHex           "91ac1e7fd668854fc7a40feec4034e42c06c068cce10622c607fda232db34c8cf5d8da83098dd89\           \1cd4cb4299b3fa0352ae323ad99b24541e54b91888fdc8201")    , testCase "Converting VKeyHash to Expression" $       M.toExpression @(T.Value 'T.TKeyHash) (getSampleValue @('T.TKeyHash)) `shouldBe`-        M.ExpressionBytes (unsafeFromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d")+        M.ExpressionBytes (unsafe $ fromHex "0092629ed0afa9cd42835ce09ee2623c1efa0b590d")    , testCase "Converting VBls12381Fr to Expression" $       M.toExpression @(T.Value 'T.TBls12381Fr) (getSampleValue @('T.TBls12381Fr)) `shouldBe`-          M.ExpressionBytes (unsafeFromHex "0100000000000000000000000000000000000000000000000000000000000000")+          M.ExpressionBytes (unsafe $ fromHex "0100000000000000000000000000000000000000000000000000000000000000")    , testCase "Converting VLam to Expression" $       M.toExpression @(T.Value $ 'T.TLambda 'T.TUnit 'T.TUnit)@@ -472,7 +473,7 @@             ]    , testCase "Converting NTPair to Expression" $-      M.toExpression (T.NTPair "pair" "a" "b" U.noAnn U.noAnn (T.NTString U.noAnn) (T.NTInt "val")) `shouldBe`+      M.toExpression [notes|pair :pair (string %a) (int %b :val)|] `shouldBe`         M.ExpressionPrim           (M.MichelinePrimAp               { mpaPrim = M.MichelinePrimitive "pair"@@ -553,4 +554,4 @@             }      getSampleValue :: forall t. (T.SingI t) => T.Value t-    getSampleValue = fromJust $ T.sampleTypedValue $ T.sing @t+    getSampleValue = Unsafe.fromJust $ T.sampleTypedValue $ T.sing @t

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for operation size evaluation. @@ -14,7 +13,7 @@  import Prelude hiding (EQ) -import qualified Data.Text as T+import Data.Text qualified as T import Fmt (pretty) import Hedgehog (Gen) import Test.HUnit (Assertion, (@?=))@@ -23,12 +22,12 @@  import Hedgehog.Gen.Tezos.Address (genAddress) import Hedgehog.Gen.Tezos.Crypto (genKeyHash)-import qualified Hedgehog.Gen.Tezos.Crypto.Ed25519 as Ed25519-import qualified Hedgehog.Gen.Tezos.Crypto.Secp256k1 as Secp256k1+import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519+import Hedgehog.Gen.Tezos.Crypto.Secp256k1 qualified as Secp256k1 import Morley.Michelson.Macro-import qualified Morley.Michelson.Parser as Parser+import Morley.Michelson.Parser qualified as Parser import Morley.Michelson.Typed-import Morley.Michelson.Untyped (unsafeBuildEpName)+import Morley.Michelson.Untyped (buildEpName) import Morley.Michelson.Untyped.OpSize import Morley.Tezos.Core import Morley.Tezos.Crypto@@ -107,9 +106,9 @@     , valueTestCaseExt "plain KT address" "address" (dquotes $ pretty (gen genAddress)) 47     , let addr = gen genAddress       in valueTestCaseExt "empty entrypoint" "address" (dquotes $ pretty addr <> "%") 48-    , let epAddr = EpAddress(gen genAddress) (unsafeBuildEpName "a")+    , let epAddr = EpAddress (gen genAddress) . unsafe $ buildEpName "a"       in valueTestCaseExt "short entrypoint" "address" (dquotes $ pretty epAddr) 49-    , let epAddr = EpAddress (gen genAddress) (unsafeBuildEpName . mconcat $ replicate 8 "a")+    , let epAddr = EpAddress (gen genAddress) . unsafe . buildEpName . mconcat $ replicate 8 "a"       in valueTestCaseExt "long entrypoint" "address" (dquotes $ pretty epAddr) 56     ]   -- ed25519 and secp256k1 keys have different size@@ -201,7 +200,7 @@   ]   where   typeTestCase t gas =-    testCase (show t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas+    testCase (toString t) $ ("DUP; CONTRACT " <> t <> "; DROP") ?== gas  test_Instructions :: [TestTree] test_Instructions =@@ -272,7 +271,7 @@     namedInstrTestCase testName (instr <> "; FAILWITH") gas    instrTestCase instr gas =-    namedInstrTestCase (show instr) instr gas+    namedInstrTestCase (toString instr) instr gas    instrTestCaseFailWith instr gas =     instrTestCase (instr <> "; FAILWITH") gas

@@ -1,7 +1,9 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ -- | Tests for optimizer.  module Test.Optimizer@@ -30,21 +32,21 @@ import Prelude hiding (EQ)  import Data.Default (def)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Data.Text.Lazy (strip) import Test.HUnit (Assertion, (@?=))  import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Optimizer import Morley.Michelson.Printer (printSomeContract)+import Morley.Michelson.Runtime.Import (importUsing, readSomeContractExt) import Morley.Michelson.Text import Morley.Michelson.TypeCheck (mapSomeContract)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Michelson.Untyped.Annotation (noAnn) import Morley.Util.PeanoNatural (PeanoNatural(..)) import Test.Cleveland.Instances ()-import Test.Cleveland.Michelson (importSomeContract)  import Test.Util.Contracts import Test.Util.HUnit@@ -263,7 +265,7 @@   where     optimizerTest :: (FilePath, FilePath) -> Assertion     optimizerTest (srcPath, optPath) = do-      someContract <- importSomeContract srcPath+      someContract <- importUsing readSomeContractExt srcPath       let         optimized :: T.SomeContract         optimized = mapSomeContract (optimize . dropWithLoc) someContract

@@ -1,37 +1,38 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ module Test.Parser-  ( unit_Parse_contracts-  , unit_Parse_bad_contracts-  , unit_Value-  , unit_string_literal-  , unit_annotation-  , unit_IF-  , unit_MAP-  , unit_PAIR-  , unit_UNPAIR-  , unit_pair_type-  , unit_Right_combed_pair_type-  , unit_Right_combed_pair_type_with_annotations-  , unit_tuple_type-  , unit_or_type-  , unit_lambda_type-  , unit_list_type-  , unit_set_type-  , unit_Pair_constructor-  , unit_Right_combed_Pair_constructor-  , unit_PrintComment-  , unit_ParserException-  , unit_letType-  , unit_block_comment-  , unit_UNPAPAIR+  ( test_parse_contracts+  , test_value+  , test_string_literal+  , test_annotation+  , test_IF+  , test_MAP+  , test_PAIR+  , test_UNPAIR+  , test_pair_type+  , test_tuple_type+  , test_or_type+  , test_lambda_type+  , test_list_type+  , test_set_type+  , test_Pair_constructor+  , test_printComment+  , test_parser_exception+  , test_letType+  , test_block_comment+  , test_UNPAPAIR+  , test_mandatory_spaces   ) where -import qualified Data.List.NonEmpty as NE-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)-import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy)+import Data.List.NonEmpty qualified as NE+import Data.Text.IO.Utf8 qualified as Utf8 (readFile)+import Test.Hspec (shouldBe, shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase) import Text.Megaparsec (parse) import Text.Megaparsec.Error   (ErrorFancy(ErrorCustom), ErrorItem(Tokens), ParseError(FancyError, TrivialError), bundleErrors)@@ -41,191 +42,241 @@ import Morley.Michelson.Parser as P import Morley.Michelson.Parser.Annotations as PA import Morley.Michelson.Parser.Lexer as PL+import Morley.Michelson.Parser.Types (LetEnv, Parser') import Morley.Michelson.Untyped as Mo import Morley.Util.Positive import Test.Cleveland.Instances () import Test.Util.Contracts (getIllTypedContracts, getUnparsableContracts, getWellTypedContracts) -unit_Parse_contracts :: Expectation-unit_Parse_contracts = do-  files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts-  mapM_ (checkFile True) files+----------------------------------------------------------------------------+-- Contracts+---------------------------------------------------------------------------- -unit_Parse_bad_contracts :: Expectation-unit_Parse_bad_contracts = do-  files <- getUnparsableContracts-  mapM_ (checkFile False) files+test_parse_contracts :: [TestTree]+test_parse_contracts =+  [ testCase "well-typed and ill-typed contracts are parsable" $ do+      files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts+      mapM_ (checkFile True) files+  , testCase "bad contracts are unparsable" $ do+      files <- getUnparsableContracts+      mapM_ (checkFile False) files+  ] -checkFile :: Bool -> FilePath -> Expectation-checkFile shouldParse file = do-  code <- Utf8.readFile file-  case parse P.program file code of-    Left err-      | shouldParse -> expectationFailure $ errorBundlePretty err-    Right _-      | not shouldParse -> expectationFailure $ "Managed to parse " <> file-    _ -> pass+----------------------------------------------------------------------------+-- Values+---------------------------------------------------------------------------- -unit_Value :: Expectation-unit_Value = do-  P.parseNoEnv P.value codeSrc "{}" `shouldBe`-    Right Mo.ValueNil-  P.parseNoEnv P.value codeSrc "{PUSH int 5;}" `shouldBe`-    (Right . ValueLambda $ NE.fromList-      [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]+test_value :: [TestTree]+test_value = testSatisfyingCases P.value+  [ ( "{}"+    , Right Mo.ValueNil     )-  P.parseNoEnv P.value codeSrc "{1; 2}" `shouldBe`-    (Right . Mo.ValueSeq $ NE.fromList-      [Mo.ValueInt 1, Mo.ValueInt 2]+  , ( "{PUSH int 5;}"+    , Right . ValueLambda $ NE.fromList+        [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 1)]     )-  P.parseNoEnv P.value codeSrc "{Elt 1 2; Elt 3 4}" `shouldBe`-    (Right . Mo.ValueMap $ NE.fromList-      [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]+  , ( "{1; 2}"+    , Right . Mo.ValueSeq $ NE.fromList+        [Mo.ValueInt 1, Mo.ValueInt 2]     )-  P.parseNoEnv P.value codeSrc "{DIP DROP;}" `shouldBe`-    Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))-  P.parseNoEnv P.value codeSrc "{DIP DROP;somecontent}" `shouldSatisfy` isLeft-  P.parseNoEnv P.value codeSrc "{{ }; {}; {PUSH int 5; DROP}}" `shouldBe`-    Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1)-            :| [ Mo.Seq [] (srcPos 0 6)-               , Mo.Seq [Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)-                        , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)-               ]-           ))-  P.parseNoEnv P.value codeSrc "{{}; {}; {5}}" `shouldBe`-    Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))-  P.parseNoEnv P.value codeSrc "{{}; {5}; {Push int 5}}" `shouldSatisfy` isLeft--unit_string_literal :: Expectation-unit_string_literal = do-  P.parseNoEnv P.stringLiteral codeSrc "\"\"" `shouldSatisfy` isRight-  P.parseNoEnv P.stringLiteral codeSrc "\" \\n  \"" `shouldSatisfy` isRight-  P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft-  P.parseNoEnv P.stringLiteral codeSrc "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft--unit_annotation :: Expectation-unit_annotation = do-  P.parseNoEnv PA.noteV codeSrc "@" `shouldSatisfy` isRight-  P.parseNoEnv PA.noteV codeSrc "@_" `shouldSatisfy` isRight-  P.parseNoEnv PA.noteV codeSrc "@a." `shouldSatisfy` isRight-  P.parseNoEnv PA.noteV codeSrc "@7a" `shouldSatisfy` isRight-  P.parseNoEnv PA.noteV codeSrc "@.a" `shouldSatisfy` isLeft-  P.parseNoEnv PA.noteV codeSrc "@@@" `shouldSatisfy` isLeft-  P.parseNoEnv PA.noteV codeSrc "@a b" `shouldSatisfy` isLeft-  P.parseNoEnv PA.noteV codeSrc "@a\\" `shouldSatisfy` isLeft-  -- TODO [#48] these are special annotations and should not always be accepted-  P.parseNoEnv PA.noteV codeSrc "@%" `shouldSatisfy` isRight-  P.parseNoEnv PA.noteV codeSrc "@%%" `shouldSatisfy` isRight--unit_IF :: Expectation-unit_IF = do-  P.parseNoEnv P.codeEntry codeSrc "{IF {} {};}" `shouldBe`-    Prelude.Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]-  P.parseNoEnv P.codeEntry codeSrc "{IFEQ {} {};}" `shouldBe`-    Prelude.Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]-  P.parseNoEnv P.codeEntry codeSrc "{IFCMPEQ {} {};}" `shouldBe`-    Prelude.Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]--unit_MAP :: Expectation-unit_MAP = do-  parseNoEnv P.codeEntry codeSrc "{MAP {};}" `shouldBe`-    Prelude.Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]-  parseNoEnv P.codeEntry codeSrc "{MAP_CAR {};}" `shouldBe`-    Prelude.Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]--unit_PAIR :: Expectation-unit_PAIR = do-  P.parseNoEnv P.codeEntry codeSrc "{PAIR;}" `shouldBe`-    Prelude.Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]-  P.parseNoEnv P.codeEntry codeSrc "{PAIR %a;}" `shouldBe`-    Prelude.Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]-  P.parseNoEnv P.codeEntry codeSrc "{PAIR %0;}" `shouldBe`-    Prelude.Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]-  P.parseNoEnv P.codeEntry codeSrc "{PAPAIR;}" `shouldBe`-    Prelude.Right-      [flip Mac (srcPos 0 1) $-        PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))-          noAnn noAnn-      ]--unit_UNPAPAIR :: Expectation-unit_UNPAPAIR = do-  let unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1)--  P.parseNoEnv P.codeEntry "" "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}" `shouldBe`-    Prelude.Right [unpapair]--  P.parseNoEnv P.codeEntry "" "{UNPAPAIR @a %b @c %d %e @f;}" `shouldBe`-    Prelude.Right [unpapair]--  P.parseNoEnv P.codeEntry "" "{UNPAPAIR;}" `shouldBe`-    Prelude.Right [unpapair]--unit_UNPAIR :: Expectation-unit_UNPAIR = do-  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]+  , ( "{Elt 1 2; Elt 3 4}"+    , Right . Mo.ValueMap $ NE.fromList+        [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]+    )+  , ( "{DIP DROP;}"+    , Right (Mo.ValueLambda (Mo.Prim (Mo.DIP [Mo.Prim Mo.DROP (srcPos 0 5)]) (srcPos 0 1) :| []))+    )+  , ( "{{ }; {}; {PUSH int 5; DROP}}"+    , Right (Mo.ValueLambda (Mo.Seq [] (srcPos 0 1) :|+              [ Mo.Seq [] (srcPos 0 6)+              , Mo.Seq [ Mo.Prim (Mo.PUSH noAnn (Mo.Ty Mo.TInt noAnn) (Mo.ValueInt 5)) (srcPos 0 11)+                       , Mo.Prim Mo.DROP (srcPos 0 23)] (srcPos 0 10)+              ]))+    )+  , ( "{{}; {}; {5}}"+    , Right (Mo.ValueSeq (Mo.ValueNil :| [Mo.ValueNil, Mo.ValueSeq (Mo.ValueInt 5 :| [])]))+    )+  ] ++ -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %a;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]+  testSatisfyingCasesPredicate P.value+    [ ("{DIP DROP;somecontent}", isLeft)+    , ("{{}; {5}; {Push int 5}}", isLeft)+    ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]+test_string_literal :: [TestTree]+test_string_literal = testSatisfyingCasesPredicate P.stringLiteral+  [ ("\"\"", isRight)+  , ("\" \\n  \"", isRight)+  , ("\"abacaba \\t \n\n\r a\"", isLeft)+  , ("\"abacaba \\t \\n\\n\\r", isLeft)+  ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a %b;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]+----------------------------------------------------------------------------+-- Annotations+---------------------------------------------------------------------------- -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %b @a;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]+test_annotation :: [TestTree]+test_annotation = testSatisfyingCasesPredicate PA.noteV+  [ ("@", isRight)+  , ("@_", isRight)+  , ("@a.", isRight)+  , ("@7a", isRight)+  , ("@.a", isLeft)+  , ("@@@", isLeft)+  , ("@a b", isLeft)+  , ("@a\\", isLeft)+  -- TODO [#48] these are special annotations and should not always be accepted+  , ("@%", isRight)+  , ("@%%", isRight)+  ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]+----------------------------------------------------------------------------+-- Instructions+---------------------------------------------------------------------------- -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]+test_IF :: [TestTree]+test_IF = testSatisfyingCases P.codeEntry+  [ ( "{IF {} {};}"+    , Right [Mo.Prim (Mo.IF [] []) (srcPos 0 1)]+    )+  , ( "{IFEQ {} {};}"+    , Right [Mo.Mac (Mo.IFX (Mo.EQ noAnn) [] []) (srcPos 0 1)]+    )+  , ( "{IFCMPEQ {} {};}"+    , Right [Mo.Mac (Mo.IFCMP (Mo.EQ noAnn) noAnn [] []) (srcPos 0 1)]+    )+  ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]+test_MAP :: [TestTree]+test_MAP = testSatisfyingCases P.codeEntry+  [ ( "{MAP {};}"+    , Right [Mo.Prim (Mo.MAP noAnn []) (srcPos 0 1)]+    )+  , ( "{MAP_CAR {};}"+    , Right [Mo.Mac (Mo.MAP_CADR [Mo.A] noAnn noAnn []) (srcPos 0 1)]+    )+  ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR @a @b %c %d;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]+test_PAIR :: [TestTree]+test_PAIR = testSatisfyingCases P.codeEntry+  [ ( "{PAIR;}"+    , Right [Mo.Prim (PAIR noAnn noAnn noAnn noAnn) (srcPos 0 1)]+    )+  , ( "{PAIR %a;}"+    , Right [Mo.Prim (PAIR noAnn noAnn "a" noAnn) (srcPos 0 1)]+    )+  , ( "{PAIR %0;}"+    , Right [Mo.Prim (PAIR noAnn noAnn "0" noAnn) (srcPos 0 1)]+    )+  , ( "{PAPAIR;}"+    , Right+        [flip Mac (srcPos 0 1) $+          PAPAIR (P (F noAnn) (P (F noAnn) (F noAnn)))+            noAnn noAnn+        ]+    )+  ] -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]+test_UNPAPAIR :: [TestTree]+test_UNPAPAIR = testSatisfyingCases P.codeEntry+  [ ( "{UNPAPAIR @v1 @v2 @v3 @v4 @v5 %f1 %f2 %f3 %f4 %f5;}"+    , Right [unpapair]+    )+  , ( "{UNPAPAIR @a %b @c %d %e @f;}"+    , Right [unpapair]+    )+  , ( "{UNPAPAIR;}"+    , Right [unpapair]+    )+  ]+  where+    unpapair = Mo.Mac (UNPAPAIR (UP UF (UP UF UF))) (srcPos 0 1) -  P.parseNoEnv P.codeEntry codeSrc "{UNPAIR %c %d @a @b;}" `shouldBe`-    Prelude.Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]+test_UNPAIR :: [TestTree]+test_UNPAIR = testSatisfyingCases P.codeEntry+  [ ( "{UNPAIR;}"+    , Right [Mo.Prim (UNPAIR "" "" "" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR %a;}"+    , Right [Mo.Prim (UNPAIR "" "" "a" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR @a;}"+    , Right [Mo.Prim (UNPAIR "a" "" "" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR @a %b;}"+    , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR %b @a;}"+    , Right [Mo.Prim (UNPAIR "a" "" "b" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR @a @b;}"+    , Right [Mo.Prim (UNPAIR "a" "b" "" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR %c %d;}"+    , Right [Mo.Prim (UNPAIR "" "" "c" "d") (srcPos 0 1)]+    )+  , ( "{UNPAIR @a @b %c;}"+    , Right [Mo.Prim (UNPAIR "a" "b" "c" "") (srcPos 0 1)]+    )+  , ( "{UNPAIR @a @b %c %d;}"+    , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]+    )+  , ( "{UNPAIR %c %d @a;}"+    , Right [Mo.Prim (UNPAIR "a" "" "c" "d") (srcPos 0 1)]+    )+  , ( "{UNPAIR %c %d @a @b;}"+    , Right [Mo.Prim (UNPAIR "a" "b" "c" "d") (srcPos 0 1)]+    )+  ] ++ -  -- should fail because the two field anns are not "grouped" together.-  handleTrivialError-    "{UNPAIR %c @a @b %d;}"-    (P.codeEntry)-    (Tokens ('%' :| ""))+  [ -- should fail because the two field anns are not "grouped" together.+    handleTrivialError+      "{UNPAIR %c @a @b %d;}"+      P.codeEntry+      (Tokens ('%' :| ""))+  , -- should fail because the two var anns are not "grouped" together.+    handleTrivialError+      "{UNPAIR @a %c %d @b;}"+      P.codeEntry+      (Tokens ('@' :| ""))+  ] -  -- should fail because the two var anns are not "grouped" together.-  handleTrivialError-    "{UNPAIR @a %c %d @b;}"-    (P.codeEntry)-    (Tokens ('@' :| ""))+----------------------------------------------------------------------------+-- Types+---------------------------------------------------------------------------- -unit_pair_type :: Expectation-unit_pair_type = do-  P.parseNoEnv P.type_ codeSrc "pair unit unit" `shouldBe` Right unitPair-  P.parseNoEnv P.type_ codeSrc "(unit, unit)" `shouldBe` Right unitPair-  P.parseNoEnv P.type_ codeSrc "(key, (int, (string, bool)))"-    `shouldSatisfy` isRight-  P.parseNoEnv P.type_ codeSrc "(signature, chain_id, string, bool)"-    `shouldSatisfy` isRight+test_pair_type :: [TestTree]+test_pair_type =+  [ testGroup "simple pair type" $+    testSatisfyingCases P.type_+      [ ("pair unit unit", Right unitPair)+      , ("(unit, unit)", Right unitPair)+      ]+    +++    testSatisfyingCasesPredicate P.type_+      [ ("(key, (int, (string, bool)))", isRight)+      , ("(signature, chain_id, string, bool)", isRight)+      ]+  , testGroup "right-combed pair type" $+      testSatisfyingCases P.type_+        [ ("pair unit int string", Right rightCombPair)+        , ("(unit, int, string)", Right rightCombPair)+        ]+  , testGroup "right-combed pair type with annotations" $+      testSatisfyingCases P.type_+        [ ( "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)"+          , Right rightCombPairWithAnns+          )+        , ( "(unit :t1 %x, int :t2 %y, string %z :t3) :t"+          , Right rightCombPairWithAnns+          )+        ]+  ]   where     unitPair :: Mo.Ty     unitPair =       Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn -unit_Right_combed_pair_type :: Expectation-unit_Right_combed_pair_type = do-  P.parseNoEnv P.type_ codeSrc "pair unit int string" `shouldBe` Right rightCombPair-  P.parseNoEnv P.type_ codeSrc "(unit, int, string)" `shouldBe` Right rightCombPair-  where     rightCombPair :: Mo.Ty     rightCombPair =       Mo.Ty@@ -241,11 +292,6 @@         )         noAnn -unit_Right_combed_pair_type_with_annotations :: Expectation-unit_Right_combed_pair_type_with_annotations = do-  P.parseNoEnv P.type_ codeSrc "pair :t (unit :t1 %x) (int :t2 %y) (string %z :t3)" `shouldBe` Right rightCombPairWithAnns-  P.parseNoEnv P.type_ codeSrc "(unit :t1 %x, int :t2 %y, string %z :t3) :t" `shouldBe` Right rightCombPairWithAnns-  where     rightCombPairWithAnns :: Mo.Ty     rightCombPairWithAnns =       Mo.Ty@@ -261,57 +307,66 @@         )         "t" -unit_tuple_type :: Expectation-unit_tuple_type = do-  P.parseNoEnv P.type_ codeSrc "(int, int, bool, unit, nat)"-    `shouldBe` Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))-  P.parseNoEnv P.type_ codeSrc-    "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))"-      `shouldBe` Right (bigPair 16)+test_tuple_type :: [TestTree]+test_tuple_type = testSatisfyingCases P.type_+  [ ( "(int, int, bool, unit, nat)"+    , Right (typair (typair tyint tyint) (typair tybool (typair tyunit tynat)))+    )+  , ( "(pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat))))))))))))))))"+    , Right (bigPair 16)+    )+  ]   where     bigPair :: Integer -> Ty     bigPair n | n == 0 = tynat     bigPair n          = typair tynat (bigPair (n - 1)) -unit_or_type :: Expectation-unit_or_type = do-  P.parseNoEnv P.type_ codeSrc "or unit unit" `shouldBe` Right unitOr-  P.parseNoEnv P.type_ codeSrc "(unit | unit)" `shouldBe` Right unitOr-  P.parseNoEnv P.type_ codeSrc "(chain_id | (int | (string | bool)))"-    `shouldSatisfy` isRight-  P.parseNoEnv P.type_ codeSrc "or unit unit kek"-    `shouldSatisfy` isLeft+test_or_type :: [TestTree]+test_or_type =+  testSatisfyingCases P.type_+    [ ("or unit unit", Right unitOr)+    , ("(unit | unit)", Right unitOr)+    ]+  ++ testSatisfyingCasesPredicate P.type_+    [ ("(chain_id | (int | (string | bool)))", isRight)+    , ("or unit unit kek", isLeft)+    ]   where     unitOr :: Mo.Ty     unitOr =       Mo.Ty (Mo.TOr noAnn noAnn (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn -unit_lambda_type :: Expectation-unit_lambda_type = do-  P.parseNoEnv P.type_ codeSrc "lambda unit unit" `shouldBe` Right lambdaUnitUnit-  P.parseNoEnv P.type_ codeSrc "\\unit -> unit" `shouldBe` Right lambdaUnitUnit-  P.parseNoEnv P.type_ codeSrc "lambda int (signature, int)" `shouldSatisfy` isRight+test_lambda_type :: [TestTree]+test_lambda_type =+  satisfyingCasePredicate P.type_ "lambda int (signature, int)" isRight :+  testSatisfyingCases P.type_+    [ ("lambda unit unit", Right lambdaUnitUnit)+    , ("\\unit -> unit", Right lambdaUnitUnit)+    ]   where     lambdaUnitUnit :: Mo.Ty     lambdaUnitUnit =       Mo.Ty (Mo.TLambda (Mo.Ty Mo.TUnit noAnn) (Mo.Ty Mo.TUnit noAnn)) noAnn -unit_list_type :: Expectation-unit_list_type = do-  P.parseNoEnv P.type_ codeSrc "list unit" `shouldBe` Right unitList-  P.parseNoEnv P.type_ codeSrc "[unit]" `shouldBe` Right unitList-  P.parseNoEnv P.type_ codeSrc "[(key, key)]" `shouldSatisfy` isRight+test_list_type :: [TestTree]+test_list_type =+  satisfyingCasePredicate P.type_ "[(key, key)]" isRight :+  testSatisfyingCases P.type_+    [ ("list unit", Right unitList)+    , ("[unit]", Right unitList)+    ]   where     unitList :: Mo.Ty     unitList =       Mo.Ty (Mo.TList (Mo.Ty Mo.TUnit noAnn)) noAnn -unit_set_type :: Expectation-unit_set_type = do-  P.parseNoEnv P.type_ codeSrc "set int" `shouldBe` Right intSet-  P.parseNoEnv P.type_ codeSrc "set (pair int int)" `shouldBe` Right intPairSet-  P.parseNoEnv P.type_ codeSrc "{int}" `shouldBe` Right intSet-  P.parseNoEnv P.type_ codeSrc "{(pair int int)}" `shouldBe` Right intPairSet+test_set_type :: [TestTree]+test_set_type = testSatisfyingCases P.type_+  [ ("set int", Right intSet)+  , ("set (pair int int)", Right intPairSet)+  , ("{int}", Right intSet)+  , ("{(pair int int)}", Right intPairSet)+  ]   where     intSet :: Mo.Ty     intSet =@@ -320,104 +375,227 @@     intPairSet =       Mo.Ty (Mo.TSet (Mo.Ty (Mo.TPair noAnn noAnn noAnn noAnn (Mo.Ty Mo.TInt noAnn) (Mo.Ty Mo.TInt Mo.noAnn)) noAnn)) noAnn -unit_Pair_constructor :: Expectation-unit_Pair_constructor = do-  P.parseNoEnv P.value codeSrc "Pair Unit Unit" `shouldBe` Right unitPair-  P.parseNoEnv P.value codeSrc "(Unit, Unit)" `shouldBe` Right unitPair+----------------------------------------------------------------------------+-- Constructors+----------------------------------------------------------------------------++test_Pair_constructor :: [TestTree]+test_Pair_constructor =+  [ testGroup "simple pair constructor" $ testSatisfyingCases P.value+    [ ("Pair Unit Unit", Right unitPair)+    , ("(Unit, Unit)", Right unitPair)+    ]++  , testGroup "right-combed pair consrtuctor" $ testSatisfyingCases P.value+    [ ("Pair Unit 3 \"Hi\"", Right unitPairRightCombed)+    , ("(Unit, 3, \"Hi\")", Right unitPairRightCombed)+    ]+  ]   where     unitPair :: Mo.Value' Mo.ParsedOp     unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit -unit_Right_combed_Pair_constructor :: Expectation-unit_Right_combed_Pair_constructor = do-  P.parseNoEnv P.value codeSrc "Pair Unit 3 \"Hi\"" `shouldBe` Right unitPair-  P.parseNoEnv P.value codeSrc "(Unit, 3, \"Hi\")" `shouldBe` Right unitPair-  where-    unitPair :: Mo.Value' Mo.ParsedOp-    unitPair = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi"))+    unitPairRightCombed :: Mo.Value' Mo.ParsedOp+    unitPairRightCombed = Mo.ValuePair Mo.ValueUnit (Mo.ValuePair (Mo.ValueInt 3) (Mo.ValueString "Hi")) -unit_PrintComment :: Expectation-unit_PrintComment = do-  P.parseNoEnv P.printComment codeSrc "\"Sides are %[0] x %[1]\"" `shouldBe`-    Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])-  P.parseNoEnv P.printComment codeSrc "\"%[0] x\"" `shouldBe`-    Right (PrintComment [Right (StackRef 0), Left " x"])-  P.parseNoEnv P.printComment codeSrc "\"%[0]x%[1]\"" `shouldBe`-    Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])-  P.parseNoEnv P.printComment codeSrc "\"%[0]%[1]\"" `shouldBe`-    Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])-  P.parseNoEnv P.printComment codeSrc "\"xxx\"" `shouldBe`-    Right (PrintComment [Left "xxx"])-  P.parseNoEnv P.printComment codeSrc "\"\"" `shouldBe`-    Right (PrintComment [])+----------------------------------------------------------------------------+-- Comments+---------------------------------------------------------------------------- -unit_ParserException :: Expectation-unit_ParserException = do-  handleCustomError "0x000" P.value OddNumberBytesException-  handleCustomError "Right 0x000" P.value OddNumberBytesException-  handleCustomError "\"aaa\\r\"" P.stringLiteral-    (StringLiteralException (InvalidEscapeSequence 'r'))-  handleCustomError "\"aaa\\b\"" P.stringLiteral-    (StringLiteralException (InvalidEscapeSequence 'b'))-  handleCustomError "\"aaa\\t\"" P.stringLiteral-    (StringLiteralException (InvalidEscapeSequence 't'))-  handleCustomError "\"aaa\n\"" P.stringLiteral-    (StringLiteralException (InvalidChar '\n'))-  handleCustomError "\"aaa\r\"" P.stringLiteral-    (StringLiteralException (InvalidChar '\r'))-  handleCustomError "{ TAG 2 (int | string) }" P.codeEntry-    (WrongTagArgs 2 (UnsafePositive 2))-  handleCustomError "{ ACCESS 2 2 }" P.codeEntry-    (WrongAccessArgs 2 (UnsafePositive 2))-  handleCustomError "{ SET 2 2 }" P.codeEntry-    (WrongSetArgs 2 (UnsafePositive 2))-  handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };"-    (P.letInner P.parsedOp)-    (Tokens ('n' :| ""))+test_block_comment :: [TestTree]+test_block_comment =+  testSatisfyingCases PL.mSpace $+    [ "/* */"+    , " /* */"+    , "/* */ "+    , "/* */;"+    , "/* */ ;"+    , "/* */\n;"+    ]+    `zip` repeat (Right ()) +----------------------------------------------------------------------------+-- Delimiters+----------------------------------------------------------------------------++test_mandatory_spaces :: [TestTree]+test_mandatory_spaces =+  [ testGroup "delimiters inside single value" $ testSatisfyingCasesPredicate P.value+    [ ("Pair 1Unit", isLeft)+    , ("Pair 1/*a*/2", isRight)+    -- TODO [#744]: The next two cases should be both+    -- either valid expressions or invalid, depending on+    -- the fact what is an intended behaviour+    , ("Pair\"1\"Unit", isLeft)+    , ("Pair 1\"2\"", isLeft)+    ]++  , testGroup "delimiters inside single instruction" $ testSatisfyingCasesPredicate P.parsedOp+  -- there have to be at least one delimiter+  -- between instruction items, either space or block comment+    [ ("PUSHint 1", isLeft)+    , ("PUSH int1", isLeft)+    , ("PUSH int#a\n1", isLeft)+    , ("PUSH int/*a*/1", isRight)+    , ("PUSH int 1", isRight)+    -- TODO [#744]: The next two cases should be both+    -- either valid expressions or invalid, depending on+    -- the fact what is an intended behaviour+    , ("PUSH string\"1\"", isLeft)+    , ("PUSH (pair string int) (Pair\"1\"2)", isLeft)+    ]++  , testGroup "delimiters between instructions" $ testSatisfyingCasesPredicate P.ops+  -- instructions might not be separated by @;@+  -- iff the first one is a sequence @{a; b;...} z@+    [ ("{{ } NIL operation {}}", isLeft)+    , ("{ DROP SWAP }", isLeft)+    , ("{DROP    ; SWAP;}", isRight)+    , ("{{DROP}SWAP}", isRight)+    , ("{DROP; DIP{SWAP}}", isRight)+    ]++  , testGroup "delimiters inside type" $ (:)+  -- delimiters inside type: there might be no space after+  -- type if it's followed by one of @, | : ] .@+    ( satisfyingCasePredicate (P.letInner P.parsedOp)+        "f :: forall a. '[int] -> '[a,int,...] = {PUSH int 1};" isRight)+    ( testSatisfyingCasesPredicate P.type_+      [ ("(int,int)", isRight)+      , ("(string|nat)", isRight)+      , ("unit:u", isRight)+      , ("[int]", isRight)+      ]+    )+  ]++----------------------------------------------------------------------------+-- Others+----------------------------------------------------------------------------++test_printComment :: [TestTree]+test_printComment = testSatisfyingCases P.printComment+  [ ( "\"Sides are %[0] x %[1]\""+    , Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])+    )+  , ( "\"%[0] x\""+    , Right (PrintComment [Right (StackRef 0), Left " x"])+    )+  , ( "\"%[0]x%[1]\""+    , Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])+    )+  , ( "\"%[0]%[1]\""+    , Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])+    )+  , ( "\"xxx\""+    , Right (PrintComment [Left "xxx"])+    )+  , ( "\"\""+    , Right (PrintComment [])+    )+  ]++test_parser_exception :: [TestTree]+test_parser_exception =+  [ handleCustomError "0x000" P.value OddNumberBytesException+  , handleCustomError "Right 0x000" P.value OddNumberBytesException+  , handleCustomError "\"aaa\\r\"" P.stringLiteral+      (StringLiteralException (InvalidEscapeSequence 'r'))+  , handleCustomError "\"aaa\\b\"" P.stringLiteral+      (StringLiteralException (InvalidEscapeSequence 'b'))+  , handleCustomError "\"aaa\\t\"" P.stringLiteral+      (StringLiteralException (InvalidEscapeSequence 't'))+  , handleCustomError "\"aaa\n\"" P.stringLiteral+      (StringLiteralException (InvalidChar '\n'))+  , handleCustomError "\"aaa\r\"" P.stringLiteral+      (StringLiteralException (InvalidChar '\r'))+  , handleCustomError "{ TAG 2 (int | string) }" P.codeEntry+      (WrongTagArgs 2 (UnsafePositive 2))+  , handleCustomError "{ ACCESS 2 2 }" P.codeEntry+      (WrongAccessArgs 2 (UnsafePositive 2))+  , handleCustomError "{ SET 2 2 }" P.codeEntry+      (WrongSetArgs 2 (UnsafePositive 2))+  , handleTrivialError "type Store = (BigMap Address Nat, Nat); \ntest :: '[option int] -> '[int]\n= { IF_SOME { nop; } { PUSH int 3 }; };"+      (P.letInner P.parsedOp)+      (Tokens ('n' :| ""))+  ]++test_letType :: [TestTree]+test_letType = testSatisfyingCasesPredicate P.letType+  [ ("type kek = int", isRight)+  -- They used to be prohibited, but now we permit them.+  , ("type Parameter = int", isRight)+  , ("type Storage = int", isRight)+  ]+----------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------++checkFile :: Bool -> FilePath -> IO ()+checkFile shouldParse file = do+  code <- Utf8.readFile file+  case parse P.programExt file code of+    Left err+      | shouldParse -> assertFailure $ errorBundlePretty err+    Right _+      | not shouldParse -> assertFailure $ "Managed to parse " <> file+    _ -> pass+ handleCustomError-  :: HasCallStack => Text -> Parser a -> CustomParserException -> Expectation-handleCustomError text parser customException =+  :: HasCallStack => Text -> Parser' LetEnv a -> CustomParserException -> TestTree+handleCustomError text parser customException = testCase (toString text) $   case P.parseNoEnv parser codeSrc text of-    Right _ -> expectationFailure "expecting parser to fail"+    Right _ -> assertFailure "expecting parser to fail"     Left bundle -> case toList $ bundleErrors bundle of       [FancyError _ (toList -> [ErrorCustom e])] ->         e `shouldBe` customException       _ ->-        expectationFailure $+        assertFailure $           "expecting single ErrorCustom, but got " <>           errorBundlePretty bundle  handleTrivialError-  :: HasCallStack => Text -> Parser a -> ErrorItem Char -> Expectation-handleTrivialError text parser errorItem =+  :: HasCallStack => Text -> Parser' LetEnv a -> ErrorItem Char -> TestTree+handleTrivialError text parser errorItem = testCase (toString text) $   case P.parseNoEnv parser codeSrc text of-    Right _ -> expectationFailure "expecting parser to fail"+    Right _ -> assertFailure "expecting parser to fail"     Left bundle -> case toList $ bundleErrors bundle of       [TrivialError _ e _] ->         e `shouldBe` (Just errorItem)       _ ->-        expectationFailure $+        assertFailure $           "expecting single TrivialError, but got " <>           errorBundlePretty bundle -unit_letType :: Expectation-unit_letType = do-  P.parseNoEnv P.letType codeSrc "type kek = int" `shouldSatisfy` isRight-  -- They used to be prohibited, but now we permit them.-  P.parseNoEnv P.letType codeSrc "type Parameter = int" `shouldSatisfy` isRight-  P.parseNoEnv P.letType codeSrc "type Storage = int" `shouldSatisfy` isRight+satisfyingCasePredicate+  :: Show a+  => Parser' LetEnv a+  -> Text+  -> (Either (ParseErrorBundle Text CustomParserException) a -> Bool)+  -> TestTree+satisfyingCasePredicate parser parsedExpression predicate =+  testCase (toString parsedExpression) $+    P.parseNoEnv parser codeSrc parsedExpression `shouldSatisfy` predicate -unit_block_comment :: Expectation-unit_block_comment =-  forM_ validBlockComments $ \blockComment ->-    P.parseNoEnv PL.mSpace codeSrc blockComment `shouldBe` Right ()-  where-    validBlockComments =-      [ "/* */"-      , " /* */"-      , "/* */ "-      , "/* */;"-      , "/* */ ;"-      , "/* */\n;"-      ]+satisfyingCase+  :: (Eq a, Show a)+  => Parser' LetEnv a+  -> Text+  -> Either (ParseErrorBundle Text CustomParserException) a+  -> TestTree+satisfyingCase parser parsedExpression expected =+  satisfyingCasePredicate parser parsedExpression (== expected)++testSatisfyingCases+  :: (Eq a, Show a)+  => Parser' LetEnv a+  -> [(Text, Either (ParseErrorBundle Text CustomParserException) a)]+  -> [TestTree]+testSatisfyingCases parser = map (uncurry $ satisfyingCase parser)++testSatisfyingCasesPredicate+  :: Show a+  => Parser' LetEnv a+  -> [(Text, Either (ParseErrorBundle Text CustomParserException) a -> Bool)]+  -> [TestTree]+testSatisfyingCasesPredicate parser = map (uncurry $ satisfyingCasePredicate parser)

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for preprocessing. @@ -14,13 +13,14 @@  import Morley.Michelson.Preprocess (transformBytes, transformStrings) import Morley.Michelson.Text-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Michelson.Untyped.Annotation (noAnn)  unit_Sample_preprocess :: Assertion unit_Sample_preprocess = do-  transformStrings False (f (unsafeMkMText . toText)) (sample (T.VString . unsafeMkMText)) @?= (expected (T.VString . unsafeMkMText))+  transformStrings False (f (unsafe . mkMText . toText)) (sample (T.VString . unsafe . mkMText))+    @?= (expected (T.VString . unsafe . mkMText))   transformBytes False (f fromString) (sample T.VBytes) @?= (expected T.VBytes)   where     f :: (Eq a) => (String -> a) -> a -> a

@@ -1,7 +1,9 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ module Test.Printer.Michelson   ( unit_Roundtrip   , unit_let_macro@@ -12,7 +14,7 @@   , unit_Views   ) where -import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Data.Text.Lazy (strip) import Fmt (pretty) import Generics.SYB (everywhere, mkT)@@ -20,8 +22,9 @@  import Morley.Michelson.Parser (MichelsonSource(..)) import Morley.Michelson.Printer (printSomeContract, printUntypedContract)-import Morley.Michelson.Runtime (parseExpandContract)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Runtime (parseExpandContractExt)+import Morley.Michelson.Runtime.Import (importUsing, readUntypedContractExt)+import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Instr (ExpandedOp(..)) import Test.Cleveland.Michelson (importSomeContract, importUntypedContract) @@ -86,7 +89,7 @@   where     morleyRoundtripPrintTest :: FilePath -> Assertion     morleyRoundtripPrintTest filePath = do-      contract1 <- importUntypedContract filePath+      contract1 <- importUsing readUntypedContractExt filePath       contract2 <- printAndParse filePath contract1       -- We don't expect that `contract1` equals `contract2`,       -- because during printing we lose extra instructions.@@ -106,13 +109,13 @@ unit_let_macro :: Assertion unit_let_macro = do   let filePath = inContractsDir "ill-typed/letblock_trivial.mtz"-  contract <- printAndParse filePath =<< importUntypedContract filePath+  contract <- printAndParse filePath =<< importUsing readUntypedContractExt filePath   let ops = concatMap U.flattenExpandedOp (U.contractCode contract)   ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP]  printAndParse :: FilePath -> U.Contract -> IO U.Contract printAndParse fp contract1 =-  case parseExpandContract (MSFile fp) (toText $ printUntypedContract True contract1) of+  case parseExpandContractExt (MSFile fp) (toText $ printUntypedContract True contract1) of     Left err ->       assertFailure ("Failed to parse printed " <> fp <> ": " <> pretty err)     Right contract2 -> pure contract2

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Serialization.Aeson   ( test_Roundtrip

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE OverloadedLists #-} @@ -8,7 +7,7 @@   ( spec_Serialization   ) where -import qualified Data.Aeson as J+import Data.Aeson qualified as J import Data.Aeson.QQ (aesonQQ) import Data.Typeable (typeRep) import Test.Hspec (Spec, describe, it)@@ -17,13 +16,12 @@ import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Text import Morley.Michelson.Typed-import Morley.Tezos.Address (Address(..), unsafeParseAddress)-import Morley.Tezos.Core (Mutez, Timestamp, parseChainId, timestampFromSeconds, toMutez)+import Morley.Tezos.Address (Address(..), parseAddress)+import Morley.Tezos.Core (Mutez, Timestamp, parseChainId, timestampFromSeconds) import Morley.Tezos.Crypto   (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash(..), parseKeyHash, parsePublicKey, parseSignature)-import qualified Morley.Tezos.Crypto.BLS12381 as BLS+import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Test.Cleveland.Instances ()-import Test.Cleveland.Util import Test.Serialization.Util  spec_Serialization :: Spec@@ -180,17 +178,17 @@ mutezTest =   serializeSpec     @Mutez-    [ Example "0"   $ toMutez 0   ~: "050000"   ~: [aesonQQ| { "int": "0" } |]-    , Example "1"   $ toMutez 1   ~: "050001"   ~: [aesonQQ| { "int": "1" } |]-    , Example "63"  $ toMutez 63  ~: "05003f"   ~: [aesonQQ| { "int": "63" } |]-    , Example "64"  $ toMutez 64  ~: "05008001" ~: [aesonQQ| { "int": "64" } |]-    , Example "65"  $ toMutez 65  ~: "05008101" ~: [aesonQQ| { "int": "65" } |]-    , Example "127" $ toMutez 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127" } |]-    , Example "128" $ toMutez 128 ~: "05008002" ~: [aesonQQ| { "int": "128" } |]-    , Example "129" $ toMutez 129 ~: "05008102" ~: [aesonQQ| { "int": "129" } |]-    , Example "191" $ toMutez 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191" } |]-    , Example "192" $ toMutez 192 ~: "05008003" ~: [aesonQQ| { "int": "192" } |]-    , Example "193" $ toMutez 193 ~: "05008103" ~: [aesonQQ| { "int": "193" } |]+    [ Example "0"   $ 0   ~: "050000"   ~: [aesonQQ| { "int": "0" } |]+    , Example "1"   $ 1   ~: "050001"   ~: [aesonQQ| { "int": "1" } |]+    , Example "63"  $ 63  ~: "05003f"   ~: [aesonQQ| { "int": "63" } |]+    , Example "64"  $ 64  ~: "05008001" ~: [aesonQQ| { "int": "64" } |]+    , Example "65"  $ 65  ~: "05008101" ~: [aesonQQ| { "int": "65" } |]+    , Example "127" $ 127 ~: "0500bf01" ~: [aesonQQ| { "int": "127" } |]+    , Example "128" $ 128 ~: "05008002" ~: [aesonQQ| { "int": "128" } |]+    , Example "129" $ 129 ~: "05008102" ~: [aesonQQ| { "int": "129" } |]+    , Example "191" $ 191 ~: "0500bf02" ~: [aesonQQ| { "int": "191" } |]+    , Example "192" $ 192 ~: "05008003" ~: [aesonQQ| { "int": "192" } |]+    , Example "193" $ 193 ~: "05008103" ~: [aesonQQ| { "int": "193" } |]     ]  natTest :: Spec@@ -236,7 +234,7 @@   serializeSpec     @KeyHash     [ Example "KeyHash" $-        leftToShowPanic (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")+        unsafe (parseKeyHash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")         ~: "050a000000150002298c03ed7d454a101eb7022bc95f7e5f41ac78"         ~: [aesonQQ| { "bytes": "0002298c03ed7d454a101eb7022bc95f7e5f41ac78" } |]     ]@@ -273,7 +271,7 @@       ~: [aesonQQ| { "bytes": "019812c669d9e8ff1a61bf8c57e33b955f074d832600" } |]     ]   where-    parseAddrs = map $ first unsafeParseAddress+    parseAddrs = map $ first (unsafe . parseAddress)  keyTest :: Spec keyTest =@@ -298,12 +296,12 @@       [aesonQQ| { "bytes": "0203dcb1916c475902f2b1083212e1b4e6f8ce1531710218c7d34340439f47040e7c" } |]     ]   where-    item keyStr keyBytes json = ( leftToShowPanic $ parsePublicKey keyStr, (keyBytes, json) )+    item keyStr keyBytes json = ( unsafe $ parsePublicKey keyStr, (keyBytes, json) )  chainIdTest :: Spec chainIdTest =   serializeSpecManual VChainId "chain_id" allTestMethods $ examples-    [ leftToShowPanic+    [ unsafe           (parseChainId "NetXUdfLh6Gm88t")       ~: "0x050a00000004458aa837"       ~: [aesonQQ| { "bytes": "458aa837" } |]@@ -334,7 +332,7 @@         [aesonQQ| { "bytes": "da632d7f267673fab5a40562778a6890b6ada9665d53d7ff318e3399e032b3986588dadcf3bf3b549592f7b8ea1365273fbef5f4883c3430ed32e8ae24017be1" } |]     ]   where-    item sigStr sigBytes json = (leftToShowPanic $ parseSignature sigStr, (sigBytes, json))+    item sigStr sigBytes json = (unsafe $ parseSignature sigStr, (sigBytes, json))  contractTest :: Spec contractTest = do@@ -369,8 +367,8 @@         ~: [aesonQQ| { "bytes": "000092b72c0fa1064331a641131f572e7f2abb9a890b61" } |]     ]   where-    parseAddrs = map $ first unsafeParseAddress-    parseEpAddrs = map $ first unsafeParseEpAddress+    parseAddrs = map $ first (unsafe . parseAddress)+    parseEpAddrs = map $ first (unsafe . parseEpAddress)      mkEpVContract :: forall p. ParameterScope p => EpAddress -> Value ('TContract p)     mkEpVContract EpAddress{..} =@@ -381,7 +379,7 @@   serializeSpecManual toVal "simple ticket"     toJsonTestMethod $ examples $     [ Ticket-        { tTicketer = unsafeParseAddress "tz1Zk7f1Ywii8QS11L63YqqtcneB64QWBas9"+        { tTicketer = unsafe $ parseAddress "tz1Zk7f1Ywii8QS11L63YqqtcneB64QWBas9"         , tData = [mt|a|]         , tAmount = 10         }

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE OverloadedLists #-} @@ -10,7 +9,7 @@  import Prelude hiding (Ordering(..)) -import qualified Data.Aeson as J+import Data.Aeson qualified as J import Data.Aeson.QQ (aesonQQ) import Fmt (pretty) import Test.Hspec (Spec, describe, it, shouldSatisfy)@@ -21,9 +20,9 @@ import Morley.Michelson.Interpret.Pack (packValue', packValuePrefix, toBinary') import Morley.Michelson.Interpret.Unpack (unpackUValue', unpackValue') import Morley.Michelson.Macro (expandList)-import qualified Morley.Michelson.Parser as Parser+import Morley.Michelson.Parser qualified as Parser import Morley.Michelson.Typed-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core (ChainId(..)) import Test.Cleveland.Instances (HasInstrCallStack(..)) import Test.Cleveland.Util@@ -132,7 +131,7 @@ unpackNegSpec :: String -> Text -> Spec unpackNegSpec name encodedHex =   it name $-    let encoded = unsafeFromHex (stripOptional0x encodedHex)+    let encoded = unsafe . fromHex $ stripOptional0x encodedHex     in unpackUValue' encoded `shouldSatisfy` isLeft  deserializeNegSpec :: String -> Text -> J.Value -> Spec@@ -1223,6 +1222,13 @@               { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] },               { "prim": "SUB", "annots": [ "@s" ] }, { "prim": "DROP" } ]           |]+    , "PUSH mutez 1; PUSH mutez 2; SUB_MUTEZ @sm; DROP"+        ~: "0x0502000000170743036a00010743036a000204930000000340736d0320"+        ~: [aesonQQ|+            [ { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "1" } ] },+              { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "2" } ] },+              { "prim": "SUB_MUTEZ", "annots": [ "@sm" ] }, { "prim": "DROP" } ]+          |]     , "PUSH int 1; PUSH int 2; MUL @m; DROP"         ~: "0x0502000000160743035b00010743035b0002043a00000002406d0320"         ~: [aesonQQ|@@ -1489,6 +1495,13 @@               { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "2" } ] },               { "prim": "SUB" }, { "prim": "DROP" } ]           |]+    , "PUSH mutez 1; PUSH mutez 2; SUB_MUTEZ; DROP"+       ~: "0x0502000000100743036a00010743036a000203930320"+       ~: [aesonQQ|+            [ { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "1" } ] },+              { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "2" } ] },+              { "prim": "SUB_MUTEZ" }, { "prim": "DROP" } ]+          |]     , "PUSH int 1; PUSH int 2; MUL; DROP"        ~: "0x0502000000100743035b00010743035b0002033a0320"        ~: [aesonQQ|@@ -2658,7 +2671,7 @@     deserializeReadableSpec name encodedHex json =       describe name $ do         it "From binary" $-          let encoded = unsafeFromHex (stripOptional0x encodedHex)+          let encoded = unsafe . fromHex $ stripOptional0x encodedHex           in runUnpack @t encoded `shouldSatisfy` isRight         it "From json" $           case J.eitherDecode' @Expression (J.encode json) of@@ -2670,9 +2683,9 @@ lengthsAreNotIgnoredTest =   describe "Lengths are not ignored in ChainId" $ do     let chainId = UnsafeChainId "\0\0\0\0"-        properEncoded = unsafeFromHex "050a0000000400000000"-        badEncodedGt  = unsafeFromHex "050a0000000500000000"-        badEncodedLt  = unsafeFromHex "050a0000000300000000"+        properEncoded = unsafe $ fromHex "050a0000000400000000"+        badEncodedGt  = unsafe $ fromHex "050a0000000500000000"+        badEncodedLt  = unsafe $ fromHex "050a0000000300000000"      it "Can be properly encoded" $       unpackValue' @'TChainId properEncoded == Right (VChainId chainId)

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2021 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  {-# LANGUAGE OverloadedLists #-} @@ -18,7 +17,7 @@   , (~:)   ) where -import qualified Data.Aeson as J+import Data.Aeson qualified as J import Data.Aeson.Encode.Pretty (Indent(Spaces), confCompare, confIndent, defConfig, encodePretty') import Fmt (pretty) import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)@@ -64,7 +63,7 @@ fromBinaryTestMethodImpl doUnpack = one $   TestMethod "From binary" $     \val encodedHex _ ->-      doUnpack (unsafeFromHex encodedHex) `shouldBe` Right val+      doUnpack (unsafe . fromHex $ encodedHex) `shouldBe` Right val  toJsonTestMethodImpl :: (ToExpression t) => HasCallStack => [TestMethod t] toJsonTestMethodImpl = one $@@ -110,7 +109,7 @@ deserializeNegSpecImpl doUnpack name encodedHex json =   describe name $ do     it "From binary" $-      let encoded = unsafeFromHex (stripOptional0x encodedHex)+      let encoded = unsafe . fromHex $ stripOptional0x encodedHex       in doUnpack encoded `shouldSatisfy` isLeft     it "From json" $       case J.eitherDecode' @Expression (J.encode json) of

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'Morley.Tezos.Address'. @@ -17,10 +16,8 @@ import Test.Tasty.HUnit (testCase)  import Hedgehog.Gen.Tezos.Address (genAddress)-import Morley.Tezos.Address-  (Address, formatAddress, parseAddress, parseAddressRaw, ta, unsafeParseAddress,-  unsafeParseAddressRaw)-import Test.Cleveland.Util (fromHex, unsafeFromHex)+import Morley.Tezos.Address (formatAddress, parseAddress, ta)+import Test.Cleveland.Util (parseAddressFromHex)  import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB) @@ -37,9 +34,9 @@   [ testCase "Successfully parses valid sample data in canonical form" $     forM_ sampleAddresses (\(a, _) -> bimap STB STB (parseAddress a) `shouldSatisfy` isRight)   , testCase "Successfully parses valid sample data in raw byte form" $-    forM_ sampleAddresses (\(_, b) -> bimap STB STB (parseAddressRaw . unsafeFromHex $ b) `shouldSatisfy` isRight)+    forM_ sampleAddresses (\(_, b) -> bimap STB STB (parseAddressFromHex b) `shouldSatisfy` isRight)   , testCase "Parsed addresses are equivalent in canonical and raw byte form" $-    forM_ sampleAddresses (\(a, b) -> (STB . unsafeParseAddressRaw . unsafeFromHex $ b) @?= (STB . unsafeParseAddress $ a))+    forM_ sampleAddresses (\(a, b) -> (STB . unsafe $ parseAddressFromHex b) @?= (STB . unsafe $ parseAddress a))   , testCase "Fails to parse invalid data" $ do     forM_ invalidAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isLeft)   ]@@ -47,26 +44,21 @@ test_decodeAddress :: [TestTree] test_decodeAddress = mconcat   [ [ testCase ("Successfully encodes " <> toString b)-      (formatAddress (unsafeParseAddressRaw (unsafeFromHex b)) @?= a) | (a, b) <- sampleAddresses ]+      (formatAddress (unsafe $ parseAddressFromHex b) @?= a) | (a, b) <- sampleAddresses ]   , [ testCase ("Fails to parse invalid address " <> toString a)-      (parseInvalidAddresses a `shouldSatisfy` isNothing) | a <- invalidRawAddresses ]+      (parseAddressFromHex a `shouldSatisfy` isLeft) | a <- invalidRawAddresses ]   ]-  where-    parseInvalidAddresses :: Text -> Maybe Address-    parseInvalidAddresses a = do-      bs <- fromHex a-      rightToMaybe (parseAddressRaw bs)  unit_ta :: Assertion unit_ta = do   [ta|tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU|]-    @?= unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"+    @?= unsafe (parseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU")   [ta|tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd|]-    @?= unsafeParseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd"+    @?= unsafe (parseAddress "tz1Wit2PqodvPeuRRhdQXmkrtU8e8bRYZecd")   [ta|KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45|]-    @?= unsafeParseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45"+    @?= unsafe (parseAddress "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45")   [ta|KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh|]-    @?= unsafeParseAddress "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh"+    @?= unsafe (parseAddress "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh")  sampleAddresses :: [(Text, Text)] sampleAddresses =

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Tezos.Core   ( test_ParseTimestamp

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Tests for 'Morley.Tezos.Crypto'. @@ -14,6 +13,7 @@   , unit_Failing_Key_Hashing   ) where +import Fmt (pretty) import Test.HUnit (Assertion, assertBool, (@?=)) import Test.Hspec (Expectation, shouldSatisfy) import Test.Tasty (TestTree, testGroup)@@ -21,7 +21,7 @@  import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSecretKey, genSignature) import Morley.Tezos.Crypto-import Test.Cleveland.Util (fromHex, partialParse, unsafeFromHex)+import Test.Cleveland.Util (fromHex) import Test.Util.Hedgehog (ShowThroughBuild(..), aesonRoundtrip, roundtripTreeSTB)  test_Roundtrip :: [TestTree]@@ -220,15 +220,15 @@ checkSignatureSample sd =   checkSignature publicKey signature (sdBytes sd) @?= sdValid sd   where-    publicKey = partialParse parsePublicKey (sdPublicKey sd)-    signature = partialParse parseSignature (sdSignature sd)+    publicKey = unsafe . parsePublicKey $ sdPublicKey sd+    signature = unsafe . parseSignature $ sdSignature sd  checkRawSignatureSample :: SignatureData -> Assertion checkRawSignatureSample sd =   checkSignature publicKey signature (sdBytes sd) @?= sdValid sd   where-    publicKey = partialParse parsePublicKeyRaw (unsafeFromHex $ sdPublicKey sd)-    signature = partialParse parseSignatureRaw (unsafeFromHex $ sdSignature sd)+    publicKey = unsafe . parsePublicKeyRaw . unsafe . fromHex $ sdPublicKey sd+    signature = unsafe . parseSignatureRaw . unsafe . fromHex $ sdSignature sd  ---------------------------------------------------------------------------- -- Key hashing@@ -266,8 +266,8 @@ hashKeySample :: (Text, Text) -> Assertion hashKeySample (pkText, keyHashText) = hashKey pk @?= keyHash   where-    pk = partialParse parsePublicKey pkText-    keyHash = partialParse parseKeyHash keyHashText+    pk = unsafe $ parsePublicKey pkText+    keyHash = unsafe $ parseKeyHash keyHashText  ---------------------------------------------------------------------------- -- Parsing raw data@@ -278,22 +278,22 @@   [ testCase "Successfully parses valid sample signatures in canonical form" $     forM_ samplePairSignatures (\(a, _) -> bimap STB STB (parseSignature a) `shouldSatisfy` isRight)   , testCase "Successfully parses valid sample signatures in raw byte form" $-    forM_ samplePairSignatures (\(_, b) -> fmap STB (parseSignatureRaw . unsafeFromHex $ b) `shouldSatisfy` isRight)+    forM_ samplePairSignatures (\(_, b) -> fmap STB (parseSignatureRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight)   , testCase "Parsed signatures are equivalent in canonical and raw byte form" $     forM_ samplePairSignatures (\(a, b) ->-      (STB . (partialParse parseSignatureRaw) . unsafeFromHex $ b)-        @?= (STB . (partialParse parseSignature) $ a))+      (STB . unsafe . parseSignatureRaw . unsafe . fromHex $ b)+        @?= (STB . unsafe . parseSignature $ a))   , testGroup "Fails to parse invalid signatures:"       [ testCase (toString a)-          (parseInvalidSignature a `shouldSatisfy` isNothing) | a <- invalidRawSignatures+          (parseInvalidSignature a `shouldSatisfy` isLeft) | a <- invalidRawSignatures       ]   ]    where-    parseInvalidSignature :: Text -> Maybe Signature+    parseInvalidSignature :: Text -> Either Text Signature     parseInvalidSignature a = do       bs <- fromHex a-      rightToMaybe (parseSignatureRaw bs)+      first pretty $ parseSignatureRaw bs      samplePairSignatures :: [(Text, Text)]     samplePairSignatures =@@ -320,20 +320,20 @@   [ testCase "Successfully parses valid sample public keys in canonical form" $     forM_ sampleRawPublicKeys (\(a, _) -> bimap STB STB (parsePublicKey a) `shouldSatisfy` isRight)   , testCase "Successfully parses valid sample public keys in raw byte form" $-    forM_ sampleRawPublicKeys (\(_, b) -> fmap STB (parsePublicKeyRaw . unsafeFromHex $ b) `shouldSatisfy` isRight)+    forM_ sampleRawPublicKeys (\(_, b) -> fmap STB (parsePublicKeyRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight)   , testCase "Parsed public keys are equivalent in canonical and raw byte form" $-    forM_ sampleRawPublicKeys (\(a, b) -> (STB . (partialParse parsePublicKeyRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parsePublicKey) $ a))+    forM_ sampleRawPublicKeys (\(a, b) -> (STB . unsafe . parsePublicKeyRaw . unsafe . fromHex $ b) @?= (STB . unsafe . parsePublicKey $ a))   , testGroup "Fails to parse invalid public keys:"       [ testCase (toString a)-          (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawPublicKeys+          (parseInvalidKey a `shouldSatisfy` isLeft) | a <- invalidRawPublicKeys       ]   ]    where-    parseInvalidKey :: Text -> Maybe PublicKey+    parseInvalidKey :: Text -> Either Text PublicKey     parseInvalidKey a = do       bs <- fromHex a-      rightToMaybe (parsePublicKeyRaw bs)+      first pretty $ parsePublicKeyRaw bs      sampleRawPublicKeys :: [(Text, Text)]     sampleRawPublicKeys =@@ -359,19 +359,19 @@   [ testCase "Successfully parses valid sample key hashes in canonical form" $     forM_ sampleRawKeyHashes (\(a, _) -> bimap STB STB (parseKeyHash a) `shouldSatisfy` isRight)   , testCase "Successfully parses valid sample key hashes in raw byte form" $-    forM_ sampleRawKeyHashes (\(_, b) -> fmap STB (parseKeyHashRaw . unsafeFromHex $ b) `shouldSatisfy` isRight)+    forM_ sampleRawKeyHashes (\(_, b) -> fmap STB (parseKeyHashRaw . unsafe . fromHex $ b) `shouldSatisfy` isRight)   , testCase "Parsed key hashes are equivalent in canonical and raw byte form" $-    forM_ sampleRawKeyHashes (\(a, b) -> (STB . (partialParse parseKeyHashRaw) . unsafeFromHex $ b) @?= (STB . (partialParse parseKeyHash) $ a))+    forM_ sampleRawKeyHashes (\(a, b) -> (STB . unsafe . parseKeyHashRaw . unsafe . fromHex $ b) @?= (STB . unsafe . parseKeyHash $ a))   , testGroup "Fails to parse invalid key hashes:"       [ testCase (toString a)-          (parseInvalidKey a `shouldSatisfy` isNothing) | a <- invalidRawKeyHashes+          (parseInvalidKey a `shouldSatisfy` isLeft) | a <- invalidRawKeyHashes       ]   ]   where-    parseInvalidKey :: Text -> Maybe KeyHash+    parseInvalidKey :: Text -> Either Text KeyHash     parseInvalidKey a = do       bs <- fromHex a-      rightToMaybe (parseKeyHashRaw bs)+      first pretty $ parseKeyHashRaw bs      sampleRawKeyHashes :: [(Text, Text)]     sampleRawKeyHashes =