morley 1.16.2 → 1.16.3

raw patch · 152 files changed

+5526/−2588 lines, 152 filesdep +Diffdep +th-reify-manyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Diff, th-reify-many

API changes (from Hackage documentation)

Files

• CHANGES.md +123/−0
• LICENSE +3/−1
• README.md +6/−3
• app/Main.hs +46/−30
• app/REPL.hs +18/−19
• docs/language/morleyInstructions.md +2/−0
• docs/language/morleyLanguage.md +4/−3
• docs/language/morleyLet.md +2/−0
• docs/language/morleyMacros.md +2/−0
• docs/language/morleySyntaxSugar.md +2/−0
• docs/michelsonTypes.md +2/−3
• docs/morleyInterpreter.md +6/−7
• docs/morleyRuntime.md +2/−3
• docs/morleyTypechecker.md +2/−3
• morley.cabal +18/−7
• src/Morley/AsRPC.hs +982/−0
• src/Morley/CLI.hs +9/−10
• src/Morley/Micheline.hs +2/−3
• src/Morley/Micheline/Binary.hs +8/−9
• src/Morley/Micheline/Binary/Internal.hs +7/−8
• src/Morley/Micheline/Class.hs +37/−17
• src/Morley/Micheline/Expression.hs +10/−11
• src/Morley/Micheline/Json.hs +10/−8
• src/Morley/Michelson/Analyzer.hs +5/−6
• src/Morley/Michelson/Doc.hs +16/−15
• src/Morley/Michelson/ErrorPos.hs +10/−18
• src/Morley/Michelson/FailPattern.hs +9/−10
• src/Morley/Michelson/Interpret.hs +35/−18
• src/Morley/Michelson/Interpret/Pack.hs +2/−3
• src/Morley/Michelson/Interpret/Unpack.hs +5/−6
• src/Morley/Michelson/Interpret/Utils.hs +4/−5
• src/Morley/Michelson/Let.hs +5/−4
• src/Morley/Michelson/Macro.hs +18/−10
• src/Morley/Michelson/Optimizer.hs +83/−13
• src/Morley/Michelson/Parser.hs +97/−63
• src/Morley/Michelson/Parser/Annotations.hs +19/−20
• src/Morley/Michelson/Parser/Common.hs +3/−4
• src/Morley/Michelson/Parser/Error.hs +15/−9
• src/Morley/Michelson/Parser/Ext.hs +21/−17
• src/Morley/Michelson/Parser/Helpers.hs +20/−9
• src/Morley/Michelson/Parser/Instr.hs +164/−140
• src/Morley/Michelson/Parser/Let.hs +20/−18
• src/Morley/Michelson/Parser/Lexer.hs +51/−28
• src/Morley/Michelson/Parser/Macro.hs +49/−47
• src/Morley/Michelson/Parser/Type.hs +98/−64
• src/Morley/Michelson/Parser/Types.hs +42/−7
• src/Morley/Michelson/Parser/Value.hs +50/−42
• src/Morley/Michelson/Preprocess.hs +5/−6
• src/Morley/Michelson/Printer.hs +5/−6
• src/Morley/Michelson/Printer/Util.hs +4/−4
• src/Morley/Michelson/Runtime.hs +122/−52
• src/Morley/Michelson/Runtime/Dummy.hs +7/−8
• src/Morley/Michelson/Runtime/GState.hs +59/−39
• src/Morley/Michelson/Runtime/Import.hs +57/−7
• src/Morley/Michelson/Runtime/TxData.hs +4/−5
• src/Morley/Michelson/Text.hs +9/−16
• src/Morley/Michelson/TypeCheck.hs +3/−3
• src/Morley/Michelson/TypeCheck/Error.hs +29/−27
• src/Morley/Michelson/TypeCheck/Ext.hs +10/−6
• src/Morley/Michelson/TypeCheck/Helpers.hs +21/−14
• src/Morley/Michelson/TypeCheck/Instr.hs +134/−65
• src/Morley/Michelson/TypeCheck/TypeCheck.hs +12/−22
• src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs +3/−4
• src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs +2/−3
• src/Morley/Michelson/TypeCheck/Types.hs +16/−107
• src/Morley/Michelson/TypeCheck/Value.hs +12/−14
• src/Morley/Michelson/Typed.hs +2/−3
• src/Morley/Michelson/Typed/Aliases.hs +2/−3
• src/Morley/Michelson/Typed/AnnotatedValue.hs +36/−43
• src/Morley/Michelson/Typed/Annotation.hs +101/−61
• src/Morley/Michelson/Typed/Arith.hs +19/−19
• src/Morley/Michelson/Typed/Contract.hs +2/−3
• src/Morley/Michelson/Typed/Convert.hs +55/−56
• src/Morley/Michelson/Typed/Doc.hs +14/−13
• src/Morley/Michelson/Typed/Entrypoints.hs +6/−15
• src/Morley/Michelson/Typed/Existential.hs +49/−33
• src/Morley/Michelson/Typed/Extract.hs +16/−72
• src/Morley/Michelson/Typed/Haskell.hs +2/−3
• src/Morley/Michelson/Typed/Haskell/Compatibility.hs +2/−3
• src/Morley/Michelson/Typed/Haskell/Doc.hs +5/−6
• src/Morley/Michelson/Typed/Haskell/Instr.hs +2/−3
• src/Morley/Michelson/Typed/Haskell/Instr/Helpers.hs +2/−3
• src/Morley/Michelson/Typed/Haskell/Instr/Product.hs +108/−16
• src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs +5/−5
• src/Morley/Michelson/Typed/Haskell/LooseSum.hs +4/−5
• src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs +7/−7
• src/Morley/Michelson/Typed/Haskell/Value.hs +16/−66
• src/Morley/Michelson/Typed/Instr.hs +24/−13
• src/Morley/Michelson/Typed/OpSize.hs +3/−4
• src/Morley/Michelson/Typed/Operation.hs +5/−6
• src/Morley/Michelson/Typed/Polymorphic.hs +12/−7
• src/Morley/Michelson/Typed/Scope.hs +438/−31
• src/Morley/Michelson/Typed/Sing.hs +18/−22
• src/Morley/Michelson/Typed/T.hs +27/−6
• src/Morley/Michelson/Typed/TypeLevel.hs +3/−4
• src/Morley/Michelson/Typed/Util.hs +348/−179
• src/Morley/Michelson/Typed/Value.hs +21/−116
• src/Morley/Michelson/Typed/View.hs +4/−6
• src/Morley/Michelson/Untyped.hs +2/−3
• src/Morley/Michelson/Untyped/Aliases.hs +6/−7
• src/Morley/Michelson/Untyped/Annotation.hs +30/−25
• src/Morley/Michelson/Untyped/Contract.hs +8/−3
• src/Morley/Michelson/Untyped/Entrypoints.hs +5/−11
• src/Morley/Michelson/Untyped/Ext.hs +6/−5
• src/Morley/Michelson/Untyped/Instr.hs +11/−10
• src/Morley/Michelson/Untyped/OpSize.hs +8/−4
• src/Morley/Michelson/Untyped/Type.hs +16/−6
• src/Morley/Michelson/Untyped/Value.hs +2/−3
• src/Morley/Michelson/Untyped/View.hs +5/−11
• src/Morley/Tezos/Address.hs +9/−28
• src/Morley/Tezos/Core.hs +168/−56
• src/Morley/Tezos/Crypto.hs +19/−24
• src/Morley/Tezos/Crypto/BLS12381.hs +14/−20
• src/Morley/Tezos/Crypto/Ed25519.hs +13/−8
• src/Morley/Tezos/Crypto/Hash.hs +3/−4
• src/Morley/Tezos/Crypto/P256.hs +8/−9
• src/Morley/Tezos/Crypto/Secp256k1.hs +8/−9
• src/Morley/Tezos/Crypto/Timelock.hs +42/−36
• src/Morley/Tezos/Crypto/Util.hs +14/−13
• src/Morley/Util/Aeson.hs +2/−3
• src/Morley/Util/Binary.hs +9/−10
• src/Morley/Util/ByteString.hs +2/−3
• src/Morley/Util/CLI.hs +7/−8
• src/Morley/Util/CustomGeneric.hs +19/−11
• src/Morley/Util/Default.hs +2/−3
• src/Morley/Util/Exception.hs +2/−3
• src/Morley/Util/Fcf.hs +4/−5
• src/Morley/Util/Generic.hs +5/−6
• src/Morley/Util/Instances.hs +2/−3
• src/Morley/Util/Interpolate.hs +20/−174
• src/Morley/Util/Interpolate/Internal.hs +161/−0
• src/Morley/Util/Label.hs +2/−3
• src/Morley/Util/Lens.hs +2/−3
• src/Morley/Util/Main.hs +2/−3
• src/Morley/Util/Markdown.hs +2/−3
• src/Morley/Util/MismatchError.hs +121/−0
• src/Morley/Util/Named.hs +35/−14
• src/Morley/Util/Peano.hs +199/−28
• src/Morley/Util/PeanoNatural.hs +19/−8
• src/Morley/Util/Positive.hs +3/−4
• src/Morley/Util/Sing.hs +19/−3
• src/Morley/Util/SizedList.hs +402/−0
• src/Morley/Util/SizedList/Types.hs +19/−0
• src/Morley/Util/TH.hs +17/−4
• src/Morley/Util/Text.hs +3/−4
• src/Morley/Util/Type.hs +17/−4
• src/Morley/Util/TypeLits.hs +4/−5
• src/Morley/Util/TypeTuple.hs +2/−3
• src/Morley/Util/TypeTuple/Class.hs +2/−3
• src/Morley/Util/TypeTuple/Instances.hs +2/−3
• src/Morley/Util/TypeTuple/TH.hs +3/−4
• src/Morley/Util/Typeable.hs +3/−4

@@ -1,6 +1,129 @@ <!-- Unreleased: append new entries here -->  +1.16.3+======+* [!1113](https://gitlab.com/morley-framework/morley/-/merge_requests/1113)+  Remove uses of `Parser LetEnv` due to redundant constraint.+* [!1092](https://gitlab.com/morley-framework/morley/-/merge_requests/1092)+  Add quasiquoter for `Notes t`+* [!1094](https://gitlab.com/morley-framework/morley/-/merge_requests/1094)+  Deprecate morley language extensions+  + Morley language extensions now require `--deprecated-morley-extensions` flag to parse.+  + AST constructors corresponding to the Morley language extensions are deprecated+  + Functions for parsing Michelson with Morley extensions are added and marked as deprecated:  `parseContractExt`, `parseExpandContractExt`, `readAndParseContractExt`, `prepareContractExt`.+* [!1100](https://gitlab.com/morley-framework/morley/-/merge_requests/1100)+  Support `MAP` instruction over option type+  + Add `instance SingI1 'TOption`+  + Add `instance MapOp ('TOption e)`+* [!1084](https://gitlab.com/morley-framework/morley/-/merge_requests/1084)+  Switch to the new mutez subtraction operation+* [!1107](https://gitlab.com/morley-framework/morley/-/merge_requests/1107)+  Fix redundant `SDecide Nat` constraint warning+* [!1099](https://gitlab.com/morley-framework/morley/-/merge_requests/1099)+  Update utils for `Instr` type further.+  + `CtorEffectsApp` is now applied to the leaves in the `Instr` tree.+* [!1083](https://gitlab.com/morley-framework/morley/-/merge_requests/1083)+  Add typechecking and better errors for sapling+* [!965](https://gitlab.com/morley-framework/morley/-/merge_requests/965)+  Add fixed-size lists to Morley+  + Add `Morley.Util.SizedList` introducing Peano-based fixed-size homogenous lists.+  + Use `SizedList` for `genesisAddressN`.+  + Use `SizedList` to simplify `Morley.Util.Interpolate`.+  + Add instance `ToBigMap (SizedList' n (k, v))`+  + Add `Morley.Michelson.Parser.Helpers.count`, a fixed-size list version of `Text.Megaparsec.count`.+* [!1042](https://gitlab.com/morley-framework/morley/-/merge_requests/1042)+  Amend Morley.Util.Named+  + Re-export `arg` and `argF`+  + Deprecate `N`, `M`, `SomeArg`, `NoArg` patterns due to potential for abuse (use `arg` or `argF` with view patterns instead)+  + Do not re-export `Name` data constructor (use `fromLabel` with a type annotation/application instead)+* [!1089](https://gitlab.com/morley-framework/morley/-/merge_requests/1089)+  Enhance and rename mutez quasiquote+  + Remove `mtzQ` quasiquoter+  + Add `tz` quasiquoter; units are XTZ by default, but can be changed with a suffix; use `[tz|123u|]`, `[tz|123μ]` or `[tz|123 micro|]` for mutez.+* [!1095](https://gitlab.com/morley-framework/morley/-/merge_requests/1095)+  Put run, transfer and originate commands under emulate parent command+* [!1072](https://gitlab.com/morley-framework/morley/-/merge_requests/1072)+  Add `runCode` to Cleveland+  + `Morley.Michelson.Runtime`:+    - Don't assign IDs to bigmaps that already have one.+    - Allow overriding a contract's balance during a `transfer`.+  + Added `MaybeRPC` and `replaceBigMapIds`.+* [!1075](https://gitlab.com/morley-framework/morley/-/merge_requests/1075)+  Handle oddly-sized integral types with the `int-cast` facilities+  + Redefine `Mutez`, `TLTime` as newtype wrappers for `Word63`, `Word62` types respectively.+  + Implement `toTLTime` conversion function using `fromIntegralNoOverflow`.+  + Delegate `mkMutez`, `toMutez`, `mkTLTime` conversion functions to convenient and safe `fromIntegral` and `fromIntegralNoOverflow`.+  + Implement safe `mtzQ` quasiquoter for creating `Mutez` values.+* [!1071](https://gitlab.com/morley-framework/morley/-/merge_requests/1071)+  Add `HasRPCRepr` typeclass+* [!1068](https://gitlab.com/morley-framework/morley/-/merge_requests/1068)+  Update some utils for `Instr` type.+  * `dfsInstr` itself got deprecated in favor of other variations of this function.+  * `CtorEffectsApp` setting in `dfsInstr`-like functions now works differently.+    Instead of specifying complex combining function as the second `ceaApplyEffects` field,+    now you should specify how to transform the monadic action (and the field is now called `ceaPostStep`).+    Please create an issue if this change does not work for you.+  * Added `isMichelsonInstr`.+  * Now exporing `analyzeInstrFailure`.+* [!1076](https://gitlab.com/morley-framework/morley/-/merge_requests/1076)+  Fix escaping in haddock for Morley.Util.Interpolate+* [!1025](https://gitlab.com/morley-framework/morley/-/merge_requests/1025)+  Reduce the number of unsafe functions at the call site+  + Remove the following `unsafeFName` constructors/converters that are used as counter-parts of safe functions and replaced with `unsafe . fName`:+    - `unsafeMkMText`+    - `unsafeMkPos`+    - `unsafeParseEpAddress`+    - `unsafeMkMutez`+    - `unsafeMkAnnotation`+    - `unsafeMkViewName`+    - `unsafeFromMichelsonBytes`+    - `unsafeParseAddressRaw`+    - `unsafeBuildEpName`+    - `unsafeMkSomeParamType`+    - `unsafeParseKeyHash`+    - `unsafeParseEpAddressRaw`+    - `unsafeMkTLTime`+    - `unsafeParseAddress`+    - `unsafeParseContractHash`+    - `unsafeMkChainId`+  + Refactor `mkPos` and `mkChainId` to return `Either` instead of `Maybe`.+* [!1063](https://gitlab.com/morley-framework/morley/-/merge_requests/1063)+  Remove redundant `SingI` constraints+* [!1060](https://gitlab.com/morley-framework/morley/-/merge_requests/1060)+  Add `Morley.AsRPC` module for mapping types to their Tezos RPC representations+* [!978](https://gitlab.com/morley-framework/morley/-/merge_requests/978)+  Make it difficult to misuse 'Show'+  + Use `Buildable` and `pretty` preferrentially.+  + Add `Buildable` instances to that effect for `ArithError`, `StackSize`, `CtorEffectsApp`, `ContractBlock`,+  + Avoid using `(+||)` and `(||+)`.+  + Use `Debug.show` where we can't use `pretty` for some reason.+* [!1057](https://gitlab.com/morley-framework/morley/-/merge_requests/1057)+  Fix `Show`, `RenderDoc`, `Builder` 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+* [!1043](https://gitlab.com/morley-framework/morley/-/merge_requests/1043)+  Extract actual + expected pattern into a datatype and show diff in type mismatch+* [!1055](https://gitlab.com/morley-framework/morley/-/merge_requests/1055)+  Add more optimization rules+  + Rules added: `DUP 1 -> DUP`, `IF x x -> x`, `DIP n { } -> Nop`, `DIG n ; DUG n -> Nop`.+  + `TestEquality` instance added for `Morley.Util.Peano.SingNat`.+  + `Morley.Util.PeanoNatural` exports two new utility functions, `eqPeanoNat` and `singPeanoNat`.+  + `Morley.Util.Type` exports a new utility function, `knownListFromSingI`+* [!1013](https://gitlab.com/morley-framework/morley/-/merge_requests/1013)+  Add `WellTyped` to complex scope constraints+  + Make `WellTyped` constraint a part of complex constraints, namely `ParameterScope`, `StorageScope`, `ConstantScope`, `PackedValScope`, `UnpackedValScope`.+* [!987](https://gitlab.com/morley-framework/morley/-/merge_requests/987)+  Make parser's separators between values and instructions mandatory+  + Add `spaces` parser which doesn't accept zero white spaces+  + Change `ops'`, that parses sequence of operations, to accept absence of `;` separator after code in brackets `a; {b; c; ...} d`+  + Add backtracking with `try` to `symbol1`+* [!1037](https://gitlab.com/morley-framework/morley/-/merge_requests/1037)+  Add synonyms for `SomeConstrainedValue`+  + Reimplement `SomeConstant`, `SomeValue`, `SomeStorage` via `SomeConstrainedValue`.+* [!1035](https://gitlab.com/morley-framework/morley/-/merge_requests/1035)+  Better type errors on invalid int casts+ 1.16.2 ====== * [!1045](https://gitlab.com/morley-framework/morley/-/merge_requests/1045)

@@ -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

@@ -8,6 +8,7 @@ 2. A [library](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-library) with core Tezos and Michelson data types, and functions such as Michelson typechecker and interpreter. 3. A superset of the Michelson language that we call the [Morley language](https://gitlab.com/morley-framework/morley/-/tree/master/code/morley#morley-language). It relaxes Michelson parser rules, adds some syntax sugar and simple features.+**deprecated**  ## Morley executable @@ -40,9 +41,9 @@ Morley executable does not interact with Tezos node and Tezos network. It works in _emulated environment_ which is stored in a simple JSON file on disk. The following commands depend on environment and may modify it:-- `originate` a contract.-- `transfer` tokens to a given address (and call a smart contract if it's the destination).-- `run` a contract. A given contract is being originated first, and then the transaction is being sent to it.+- `emulate originate` a contract.+- `emulate transfer` tokens to a given address (and call a smart contract if it's the destination).+- `emulate run` a contract. A given contract is being originated first, and then the transaction is being sent to it.  The following commands don't depend on environment: - `optimize` a contract by replacing certain sequences of instructions with equivalent but more efficient ones.@@ -78,6 +79,8 @@ - The `Morley.Util.*` hierarchy defines various `Morley`-related utilities that are used all over the project.  ## Morley language++**NOTE:** Morley-the-language is deprecated and support for it will be removed in not-so-distant future. Features of morley-the-language are done better in `lorentz` and in some cases are superseded by new Michelson revisions.  Morley-the-language is a superset of the Michelson language, which means that each Michelson contract is also a valid Morley contract but not vice versa. There are several extensions which make it more convenient to write Michelson contracts and test them.

@@ -1,18 +1,20 @@--- 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 Main   ( main   ) where -import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile)+import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile) import Data.Version (showVersion) import Fmt (pretty) import Options.Applicative   (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short,   subparser, switch)-import qualified Options.Applicative as Opt+import Options.Applicative qualified as Opt import Options.Applicative.Help.Pretty (Doc, linebreak) import Paths_morley (version) import Text.Hex (encodeHex)@@ -22,15 +24,15 @@ import Morley.Michelson.Optimizer (optimize) import Morley.Michelson.Printer (printSomeContract, printUntypedContract) import Morley.Michelson.Runtime-  (TxData(..), originateContract, prepareContract, runContract, transfer)+  (TxData(..), originateContract, prepareContract, prepareContractExt, runContract, transfer) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)-import qualified Morley.Michelson.TypeCheck as TypeCheck+import Morley.Michelson.TypeCheck qualified as TypeCheck import Morley.Michelson.TypeCheck.Types (mapSomeContract) import Morley.Michelson.Typed (Contract'(..), SomeContract(..))-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address)-import Morley.Tezos.Core (Mutez, Timestamp(..), toMutez)+import Morley.Tezos.Core (Mutez, Timestamp(..), tz) import Morley.Tezos.Crypto import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey) import Morley.Util.CLI (mkCommandParser, outputOption)@@ -110,18 +112,20 @@   , toDryRun :: Bool   } -argParser :: Opt.Parser CmdLnArgs-argParser = subparser $+argParser :: Opt.Parser (Bool, CmdLnArgs)+argParser = ((,) <$> enableExtsOption <*>) . subparser $   printSubCmd <>   typecheckSubCmd <>-  runSubCmd <>-  originateSubCmd <>-  transferSubCmd <>+  emulateSubCmd <>   optimizeSubCmd <>   analyzeSubCmd <>   createChestSubCmd <>   replSubCmd   where+    enableExtsOption = switch $+      long "deprecated-morley-extensions" <>+      help "Enable parsing deprecated Morley extensions"+     typecheckSubCmd =       mkCommandParser "typecheck"         (TypeCheck <$> typeCheckOptions) $@@ -135,6 +139,13 @@       ("Parse a Morley contract and print corresponding Michelson " <>        "contract that can be parsed by the OCaml reference client: tezos-client") +    emulateSubCmd =+      mkCommandParser "emulate"+      (subparser $ runSubCmd+                <> originateSubCmd+                <> transferSubCmd)+      ("Set of commands to run in an emulated environment")+     runSubCmd =       mkCommandParser "run"       (Run <$> runOptions) $@@ -202,7 +213,7 @@       <*> typeCheckOptionsOption      defaultBalance :: Mutez-    defaultBalance = toMutez 4000000+    defaultBalance = [tz|4|]      optimizeOptions :: Opt.Parser OptimizeOptions     optimizeOptions = OptimizeOptions@@ -279,8 +290,8 @@  main :: IO () main = wrapMain $ do-  cmdLnArgs <- execParser programInfo-  run cmdLnArgs+  (exts, cmdLnArgs) <- execParser programInfo+  run exts cmdLnArgs   where     programInfo = info (helper <*> versionOption <*> argParser) $       mconcat@@ -293,16 +304,16 @@     versionOption = infoOption ("morley-" <> showVersion version)       (long "version" <> help "Show version.") -    run :: CmdLnArgs -> IO ()-    run args = case args of-      Print (M mInputFile)-            (M mOutputFile)-            (N forceSingleLine) -> do-        contract <- prepareContract mInputFile+    run :: Bool -> CmdLnArgs -> IO ()+    run exts args = case args of+      Print (argF #input -> mInputFile)+            (argF #output -> mOutputFile)+            (arg #singleLine -> forceSingleLine) -> do+        contract <- prepareContract' mInputFile         let write = maybe putStrLn Utf8.writeFile mOutputFile         write $ printUntypedContract forceSingleLine contract       Optimize OptimizeOptions{..} -> do-        untypedContract <- prepareContract optoContractFile+        untypedContract <- prepareContract' optoContractFile         checkedContract <-           either throwM pure . typeCheckingWith laxTcOptions $             typeCheckContract untypedContract@@ -310,13 +321,13 @@         let write = maybe putStrLn Utf8.writeFile optoOutput         write $ printSomeContract optoSingleLine optimizedContract       Analyze AnalyzeOptions{..} -> do-        untypedContract <- prepareContract aoContractFile+        untypedContract <- prepareContract' aoContractFile         SomeContract contract <-           either throwM pure . typeCheckingWith laxTcOptions $             typeCheckContract untypedContract         putTextLn $ pretty $ analyze (cCode contract)       TypeCheck TypeCheckOptions{..} -> do-        morleyContract <- prepareContract tcoContractFile+        morleyContract <- prepareContract' tcoContractFile         -- At the moment of writing, 'tcStrict' option does not change anything         -- because it affects only values parsing; but this may change         contract <- either throwM pure . typeCheckingWith tcoTcOptions@@ -325,12 +336,12 @@           putStrLn $ printSomeContract False contract         putTextLn "Contract is well-typed"       Run RunOptions {..} -> do-        michelsonContract <- prepareContract roContractFile+        michelsonContract <- prepareContract' roContractFile         void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData           ! #verbose roVerbose           ! #dryRun (not roWrite)       Originate OriginateOptions {..} -> do-        michelsonContract <- prepareContract ooContractFile+        michelsonContract <- prepareContract' ooContractFile         addr <-           originateContract             ooDBPath@@ -351,13 +362,18 @@         (chest, key) <- createChestAndChestKey ccPayload ccTime         putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)         putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)+      where+        -- TODO [#712]: Remove this next major release+        prepareContract'+          | exts = prepareContractExt+          | otherwise = prepareContract   usageDoc :: Maybe Doc usageDoc = Just $ mconcat    [ "You can use help for specific COMMAND", linebreak    , "EXAMPLE:", linebreak-   , "  morley run --help", linebreak+   , "  morley emulate run --help", linebreak    , linebreak    , "Documentation for morley tools can be found at the following links:", linebreak    , "  https://gitlab.com/morley-framework/morley/blob/master/README.md", linebreak@@ -372,7 +388,7 @@    , "  This command will parse contract stored in add1.tz", linebreak    , "  and return its representation in haskell types", linebreak    , linebreak-   , "  morley originate --contract add1.tz --storage 1 --verbose", linebreak+   , "  morley emulate originate --contract add1.tz --storage 1 --verbose", linebreak    , linebreak    , "  This command will originate contract with code stored in add1.tz", linebreak    , "  with initial storage value set to 1 and return info about", linebreak

@@ -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 {-| Implements an REPL that can execute Morley instructions.  REPL starts with an empty stack. At each instruction entered, the modified stack, or an error is@@ -18,15 +17,16 @@  import Control.Exception (IOException) import Control.Monad.Random (randomIO)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Base58 as Base58-import qualified Data.ByteString.Lazy as BSL+import Data.Aeson qualified as Aeson+import Data.ByteString.Base58 qualified as Base58+import Data.ByteString.Lazy qualified as BSL import Data.List (stripPrefix) import Data.Text as T (length, replicate, strip)-import qualified Data.Text as T (stripPrefix)+import Data.Text qualified as T (stripPrefix) import Data.Vinyl (Rec(..)) import Fmt (fmt, pretty) import System.Console.Haskeline+  (InputT, Interrupt(..), defaultSettings, getInputLine, runInputT, withInterrupt) import Text.Megaparsec (parse)  import Morley.Michelson.Interpret (interpretInstr)@@ -38,12 +38,11 @@ import Morley.Michelson.Runtime.Dummy import Morley.Michelson.Runtime.Import (readValue) import Morley.Michelson.TypeCheck-  (SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), getWTP, runTypeCheckIsolated,-  typeCheckingWith)+  (SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated, typeCheckingWith) import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)-import Morley.Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))-import qualified Morley.Michelson.Typed as T-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.TypeCheck.Types (HST(..))+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Crypto import Morley.Util.Sing (castSing) import Text.Hex (decodeHex, encodeHex)@@ -199,7 +198,7 @@                     printStack                   Left michelsonFail -> putTextLn (pretty michelsonFail)                 _ :/ (AnyOutInstr _) -> putTextLn "Encountered a FAILWITH instruction"-            Left err -> printErr $ show err+            Left err -> printErr $ pretty err           Nothing -> printErr "Casting stack failed"  printHelp :: ReplM ()@@ -225,7 +224,7 @@  parseInstructions :: Text -> Either Text [ParsedOp] parseInstructions src =-  case parseNoEnv ops MSUnspecified src of+  case parseNoEnv @() ops MSUnspecified src of     Right p -> Right p     Left err -> Left (toText $ errorBundlePretty err) @@ -243,15 +242,15 @@   -> HST xs   -> Either Text (T.Dict (T.SingI (t ': xs)), HST (t ': xs)) addValueToHST v hstIn = case T.valueTypeSanity v of-  T.Dict -> case getWTP @t of+  T.Dict -> case T.getWTP @t of     Right wtpDict -> Right (T.Dict, (T.starNotes @t, wtpDict, U.noAnn) ::&  hstIn)-    Left (NotWellTyped t cause) -> let+    Left (T.NotWellTyped t cause) -> let       U.Ty t' tann = T.toUType t       in Left $ "Value of type '" <> (renderT t' (U.fullAnnSet [tann] [] []))                 <> "' is not well typed in the provided Value because it "                 <> pretty cause <> "." -renderType :: T.SingI t => T.Notes t -> U.VarAnn -> Text+renderType :: T.Notes t -> U.VarAnn -> Text renderType notes vann = let   U.Ty t tann = T.mkUType notes   in renderT t (U.fullAnnSet [tann] [] [vann])@@ -308,7 +307,7 @@               case addValueToHST tVal hst of                 Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst                 Left err -> Left err-            Left tcError -> Left $ show tcError+            Left tcError -> Left $ pretty tcError         (Left err, _) -> Left $ pretty err         (_, Left err) -> Left $ toText $ errorBundlePretty err @@ -321,6 +320,6 @@     _ ->          -- else just call show, and indicate value has operation inside       case (v, T.sing @a) of         (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst-        _ -> addSuffix $ "(operations container:" <> show v <> ")"+        _ -> addSuffix $ "(operations container:" <> pretty v <> ")"   where     addSuffix val = val <>" :: " <> renderType notes vann <> "\n" <> showStack rst rHst

@@ -4,6 +4,8 @@ SPDX-License-Identifier: LicenseRef-MIT-TQ --> +**NOTE:** Morley extended instructions are _deprecated_. The internal representation still uses instructions described here, as those are used by Lorentz, but parsing contracts using these instructions is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future.+ # Morley Ext Instructions  Morley adds some additional instructions of its own to the existing set of

@@ -1,8 +1,9 @@ <!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ+SPDX-FileCopyrightText: 2021 Oxhead Alpha+SPDX-License-Identifier: LicenseRef-MIT-OA -->++**NOTE:** Morley language is _deprecated_. The internal representation still uses some of the extended instructions, as those are used by Lorentz, but parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future.  # Morley Language 

@@ -4,6 +4,8 @@ SPDX-License-Identifier: LicenseRef-MIT-TQ --> +**NOTE:** Morley language is _deprecated_, which includes let-block definitions. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future.+ # Let-block Definitions  In addition to the built-in macros defined in the Michelson specification,

@@ -4,6 +4,8 @@ SPDX-License-Identifier: LicenseRef-MIT-TQ --> +**NOTE:** Morley language is _deprecated_, which includes these macros. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future.+ # Morley Language: Macros and Type synonyms  Morley language supports all macros from the OCaml reference implementation and additionally introduces some extra macros and type synonyms.

@@ -4,6 +4,8 @@ SPDX-License-Identifier: LicenseRef-MIT-TQ --> +**NOTE:** Morley language is _deprecated_, which includes the syntax sugar described here. Parsing contracts using the morley language is deprecated and requires `--deprecated-morley-extensions` flag when invoking `morley`. This flag will be removed in the not-so-distant future.+ # Morley Language: Syntax Sugar  ## Summary

@@ -1,7 +1,6 @@ <!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ+SPDX-FileCopyrightText: 2021 Oxhead Alpha+SPDX-License-Identifier: LicenseRef-MIT-OA -->  # Michelson Types

@@ -1,7 +1,6 @@ <!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ+SPDX-FileCopyrightText: 2021 Oxhead Alpha+SPDX-License-Identifier: LicenseRef-MIT-OA -->  # Morley Interpreter@@ -35,11 +34,11 @@ 3. Write an updated blockchain state on disk.  An end user can apply one of the following commands to run the executor.-* The `transfer` command sends a transaction from one address to another address.+* The `emulate transfer` command sends a transaction from one address to another address. If the destination address is a smart contract, its code will be executed. Its storage will be updated, and it may return some operations which will also be executed. The destination contract must be originated first.-* The `run` command originates a smart contract and transfers tokens to it.+* The `emulate run` command originates a smart contract and transfers tokens to it. By default, it doesn't update the global state. It's intended to be used when one just wants to quickly interpret one contract and doesn't care about a global state file. The command still needs to read the DB (JSON file) to know about all originated contracts and their parameters.@@ -47,8 +46,8 @@ Other environment data can be passed from CLI, but it's not mandatory, and default values are used if they are not passed explicitly.  Examples:-* `morley transfer --to KT1L39q6uCg1wQPB796q5oQQgDW673uo1s5y --parameter 'Left 10'` (`KT1L39q6uCg1wQPB796q5oQQgDW673uo1s5y` must be originated first).-* `morley run --contract foo.tz --parameter '"aaa"' --storage Unit` (in this case the contract will be originated automatically).+* `morley emulate transfer --to KT1L39q6uCg1wQPB796q5oQQgDW673uo1s5y --parameter 'Left 10'` (`KT1L39q6uCg1wQPB796q5oQQgDW673uo1s5y` must be originated first).+* `morley emulate run --contract foo.tz --parameter '"aaa"' --storage Unit` (in this case the contract will be originated automatically).  By default, each operation uses _genesis address_ as a sender. This address initially has a lot of tokens.

@@ -1,7 +1,6 @@ <!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ+SPDX-FileCopyrightText: 2021 Oxhead Alpha+SPDX-License-Identifier: LicenseRef-MIT-OA -->  # Morley Runtime

@@ -1,7 +1,6 @@ <!---SPDX-FileCopyrightText: 2020 Tocqueville Group--SPDX-License-Identifier: LicenseRef-MIT-TQ+SPDX-FileCopyrightText: 2021 Oxhead Alpha+SPDX-License-Identifier: LicenseRef-MIT-OA -->  # Morley Typechecker

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morley-version:        1.16.2+version:        1.16.3 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -13,7 +13,7 @@ bug-reports:    https://gitlab.com/morley-framework/morley/-/issues author:         camlCase, Serokell, Tocqueville Group maintainer:     Serokell <hi@serokell.io>-copyright:      2018 camlCase, 2019-2021 Tocqueville Group+copyright:      2018 camlCase, 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license:        MIT license-file:   LICENSE build-type:     Simple@@ -37,6 +37,7 @@  library   exposed-modules:+      Morley.AsRPC       Morley.CLI       Morley.Micheline       Morley.Micheline.Binary@@ -151,15 +152,19 @@       Morley.Util.Generic       Morley.Util.Instances       Morley.Util.Interpolate+      Morley.Util.Interpolate.Internal       Morley.Util.Label       Morley.Util.Lens       Morley.Util.Main       Morley.Util.Markdown+      Morley.Util.MismatchError       Morley.Util.Named       Morley.Util.Peano       Morley.Util.PeanoNatural       Morley.Util.Positive       Morley.Util.Sing+      Morley.Util.SizedList+      Morley.Util.SizedList.Types       Morley.Util.Text       Morley.Util.TH       Morley.Util.Type@@ -194,24 +199,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@@ -223,7 +230,8 @@       ViewPatterns   ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages   build-depends:-      MonadRandom+      Diff+    , MonadRandom     , aeson     , aeson-casing     , aeson-pretty@@ -262,6 +270,7 @@     , text-manipulate     , th-lift     , th-lift-instances+    , th-reify-many     , time     , timerep     , uncaught-exception@@ -302,24 +311,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

@@ -0,0 +1,982 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | This module contains a type family for converting a type to its RPC representation,+-- and TemplateHaskell functions for deriving RPC representations for custom types.+module Morley.AsRPC+  ( TAsRPC+  , HasRPCRepr(..)+  , MaybeRPC(..)+  , deriveRPC+  , deriveRPCWithStrategy+  , deriveManyRPC+  , deriveManyRPCWithStrategy+  -- * Conversions+  , valueAsRPC+  , replaceBigMapIds+  , notesAsRPC+  -- * Entailments+  , rpcSingIEvi+  , rpcHasNoOpEvi+  , rpcHasNoBigMapEvi+  , rpcHasNoNestedBigMapsEvi+  , rpcHasNoContractEvi+  , rpcStorageScopeEvi+  ) where++import Prelude hiding (Type)+import Prelude qualified++import Control.Lens.Plated (universe)+import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\))+import Data.List qualified as List ((\\))+import Data.Singletons (Sing, withSingI)+import GHC.Generics qualified as G+import Language.Haskell.TH+  (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD),+  DerivStrategy(AnyclassStrategy), Info(TyConI), Kind, Loc(loc_module), Name, Q, TyLit(StrTyLit),+  TySynEqn(..), TyVarBndr, Type(..), cxt, instanceD, location, mkName, nameBase, ppr, reify,+  reifyInstances, standaloneDerivWithStrategyD)+import Language.Haskell.TH.ReifyMany (reifyManyTyCons)+import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames)++import Morley.Micheline (ToExpression(..))+import Morley.Michelson.Text (MText)+import Morley.Michelson.Typed+  (BigMap, BigMapId, ContractPresence(ContractAbsent), ContractRef, EpAddress, HasNoBigMap,+  HasNoContract, HasNoNestedBigMaps, HasNoOp, IsoValue, Notes(..), OpPresence(..), Operation,+  SingI(sing), SingT(..), StorageScope, T(..), ToT, Value, Value'(..), WellTyped,+  checkContractTypePresence, checkOpPresence, toVal, withDict)+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto+import Morley.Util.CustomGeneric+  (GenericStrategy, customGeneric', deriveFullType, haskellBalanced, reifyDataType)+import Morley.Util.Named hiding (Name)+import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail)++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++-- $setup+-- >>> import Morley.Michelson.Typed (T(..), BigMap, mkBigMap)+-- >>> import Morley.Michelson.Typed.Haskell.Value (BigMapId(..))+-- >>> import Morley.Michelson.Text (MText)++----------------------------------------------------------------------------+-- TAsRPC+----------------------------------------------------------------------------++{- | A type-level function that maps a Michelson type to its Tezos RPC representation.++For example, when we retrieve a contract's storage using the Tezos RPC,+all its @big_map@s will be replaced by @nat@, representing a big_map ID.++>>> :k! TAsRPC ('TBigMap 'TInt 'TString)+...+= 'TNat++>>> :k! TAsRPC ('TList ('TBigMap 'TInt 'TString))+...+= 'TList 'TNat++>>> :k! TAsRPC ('TPair 'TString ('TPair 'TAddress ('TBigMap 'TInt 'TString)))+...+= 'TPair 'TString ('TPair 'TAddress 'TNat)+++NB: As far as we are aware, details of RPC representation of Michelson+types are not documented. We know empirically that @big_map@s are+represented as their ids, and are the only type with an explicitly+different representation.++Whether @TAsRPC@ needs to propagate into type parameters then depends on+whether a value can hold big_map values.++* Values of type @option a@, @list a@, @pair a b@, and @or a b@ can+  contain big_map values, so their RPC representations are @option (TAsRPC a)@,+  @list (TAsRPC a)@, @pair (TAsRPC a) (TAsRPC b)@ and @or (TAsRPC a) (TAsRPC b)@.+* The keys of a @map k v@ cannot be big_maps, but the values can, so its+  RPC representation is @map k (TAsRPC v)@.+* Values of type @set a@ cannot contain big_maps, so its RPC+  representation is just @set a@.+* Values of type @contract a@ cannot contain big_maps either, because+  it's just a wrapper for an address and an entrypoint name, so its RPC+  representation is just @contract a@. The same reasoning applies to+  @ticket a@ and @lambda a b@.++-}+type TAsRPC :: T -> T+type family TAsRPC t where+  TAsRPC 'TKey = 'TKey+  TAsRPC 'TUnit = 'TUnit+  TAsRPC 'TSignature = 'TSignature+  TAsRPC 'TChainId = 'TChainId+  TAsRPC ('TOption t) = 'TOption (TAsRPC t)+  TAsRPC ('TList t) = 'TList (TAsRPC t)+  TAsRPC ('TSet t) = 'TSet t+  TAsRPC 'TOperation = 'TOperation+  TAsRPC ('TContract t) = 'TContract t+  TAsRPC ('TTicket t) = 'TTicket t+  TAsRPC ('TPair t1 t2) = 'TPair (TAsRPC t1) (TAsRPC t2)+  TAsRPC ('TOr t1 t2) = 'TOr (TAsRPC t1) (TAsRPC t2)+  TAsRPC ('TLambda t1 t2) = 'TLambda t1 t2+  TAsRPC ('TMap k v) = 'TMap k (TAsRPC v)+  TAsRPC ('TBigMap _ _) = 'TNat+  TAsRPC 'TInt = 'TInt+  TAsRPC 'TNat = 'TNat+  TAsRPC 'TString = 'TString+  TAsRPC 'TBytes = 'TBytes+  TAsRPC 'TMutez = 'TMutez+  TAsRPC 'TBool = 'TBool+  TAsRPC 'TKeyHash = 'TKeyHash+  TAsRPC 'TTimestamp = 'TTimestamp+  TAsRPC 'TAddress = 'TAddress+  TAsRPC 'TNever = 'TNever+  TAsRPC 'TBls12381Fr = 'TBls12381Fr+  TAsRPC 'TBls12381G1 = 'TBls12381G1+  TAsRPC 'TBls12381G2 = 'TBls12381G2+  TAsRPC 'TChest = 'TChest+  TAsRPC 'TChestKey = 'TChestKey+  TAsRPC ('TSaplingState n) = ('TSaplingState n)+  TAsRPC ('TSaplingTransaction n) = ('TSaplingTransaction n)++----------------------------------------------------------------------------+-- AsRPC+----------------------------------------------------------------------------++{- | A type-level function that maps a type to its Tezos RPC representation.++For example, when we retrieve a contract's storage using the Tezos RPC, all its 'BigMap's will be replaced+by 'BigMapId's.++So if a contract has a storage of type @T@, when we call the Tezos RPC+to retrieve it, we must deserialize the micheline expression to the type @AsRPC T@.++> AsRPC (BigMap Integer MText) ~ BigMapId Integer MText+> AsRPC [BigMap Integer MText] ~ [BigMapId Integer MText]+> AsRPC (MText, (Address, BigMap Integer MText)) ~ (MText, (Address, BigMapId Integer MText))++The following law must hold:++> TAsRPC (ToT t) ~ ToT (AsRPC t)++In other words, `ToT` and `AsRPC`/`TAsRPC` must be commutative.++@+   Storage ----------(applying ToT)-------------> ToT Storage+      |                                                |+      |                                                |+      |                                                |+(applying AsRPC)                                (applying TAsRPC)+      |                                                |+      |                                                |+      |                                                |+      |                                                V+      |                                        TAsRPC (ToT Storage)+      V                                                ~+AsRPC Storage ------(applying ToT)-----------> ToT (AsRPC Storage)+@+++This law ensures that we can go from some type @Storage@ to @AsRPC Storage@ by+composing @fromVal . valueAsRPC . toVal@.++@+   Storage ------------(toVal)--------------> Value (ToT Storage)+      |                                                |+      |                                                |+      |                                                |+(fromVal . valueAsRPC . toVal)                    (valueAsRPC)+      |                                                |+      |                                                |+      |                                                |+      |                                                V+      |                                   Value (TAsRPC (ToT Storage))+      V                                                ~+AsRPC Storage <--------(fromVal)--------- Value (ToT (AsRPC Storage))+@++-}+class (TAsRPC (ToT t) ~ ToT (AsRPC t)) => HasRPCRepr (t :: Prelude.Type) where+  type AsRPC t :: Prelude.Type++-- Morley types++-- Note: We don't recursively apply @AsRPC@ to @k@ or @v@ because+-- bigmaps cannot contain nested bigmaps.+-- If this constraint is ever lifted, we'll have to change this instance+-- to @BigMapId k (AsRPC v)@+instance HasRPCRepr (BigMap k v) where type AsRPC (BigMap k v) = BigMapId k v+instance HasRPCRepr (Value t) where type AsRPC (Value t) = Value (TAsRPC t)+instance HasRPCRepr Integer where type AsRPC Integer = Integer+instance HasRPCRepr Natural where type AsRPC Natural = Natural+instance HasRPCRepr MText where type AsRPC MText = MText+instance HasRPCRepr Bool where type AsRPC Bool = Bool+instance HasRPCRepr ByteString where type AsRPC ByteString = ByteString+instance HasRPCRepr Mutez where type AsRPC Mutez = Mutez+instance HasRPCRepr KeyHash where type AsRPC KeyHash = KeyHash+instance HasRPCRepr Timestamp where type AsRPC Timestamp = Timestamp+instance HasRPCRepr Address where type AsRPC Address = Address+instance HasRPCRepr EpAddress where type AsRPC EpAddress = EpAddress+instance HasRPCRepr PublicKey where type AsRPC PublicKey = PublicKey+instance HasRPCRepr Signature where type AsRPC Signature = Signature+instance HasRPCRepr ChainId where type AsRPC ChainId = ChainId+instance HasRPCRepr Bls12381Fr where type AsRPC Bls12381Fr = Bls12381Fr+instance HasRPCRepr Bls12381G1 where type AsRPC Bls12381G1 = Bls12381G1+instance HasRPCRepr Bls12381G2 where type AsRPC Bls12381G2 = Bls12381G2+instance HasRPCRepr () where type AsRPC () = ()+instance HasRPCRepr a => HasRPCRepr [a] where+  type AsRPC [a] = [AsRPC a]+instance HasRPCRepr a => HasRPCRepr (Maybe a) where+  type AsRPC (Maybe a) = Maybe (AsRPC a)+instance (HasRPCRepr l, HasRPCRepr r) => HasRPCRepr (Either l r) where+  type AsRPC (Either l r) = Either (AsRPC l) (AsRPC r)+instance (HasRPCRepr a, HasRPCRepr b) => HasRPCRepr (a, b) where+  type AsRPC (a, b) = (AsRPC a, AsRPC b)+instance HasRPCRepr (Set a) where+  type AsRPC (Set a) = Set a+instance HasRPCRepr v => HasRPCRepr (Map k v) where+  type AsRPC (Map k v) = Map k (AsRPC v)+instance HasRPCRepr Operation where+  type AsRPC Operation = Operation+instance HasRPCRepr a => HasRPCRepr (Identity a) where+  type AsRPC (Identity a) = Identity (AsRPC a)+instance HasRPCRepr a => HasRPCRepr (NamedF Identity a name) where+  type AsRPC (NamedF Identity a name) = NamedF Identity (AsRPC a) name+instance HasRPCRepr a => HasRPCRepr (NamedF Maybe a name) where+  type AsRPC (NamedF Maybe a name) = NamedF Maybe (AsRPC a) name+instance Each '[HasRPCRepr] '[a, b, c] => HasRPCRepr (a, b, c) where+  type AsRPC (a, b, c) = (AsRPC a, AsRPC b, AsRPC c)+instance Each '[HasRPCRepr] '[a, b, c, d] => HasRPCRepr (a, b, c, d) where+  type AsRPC (a, b, c, d) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d)+instance Each '[HasRPCRepr] '[a, b, c, d, e] => HasRPCRepr (a, b, c, d, e) where+  type AsRPC (a, b, c, d, e) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e)+instance Each '[HasRPCRepr] '[a, b, c, d, e, f] => HasRPCRepr (a, b, c, d, e, f) where+  type AsRPC (a, b, c, d, e, f) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f)+instance Each '[HasRPCRepr] '[a, b, c, d, e, f, g] => HasRPCRepr (a, b, c, d, e, f, g) where+  type AsRPC (a, b, c, d, e, f, g) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f, AsRPC g)+instance HasRPCRepr (ContractRef arg) where+  type AsRPC (ContractRef arg) = ContractRef arg+instance HasRPCRepr Chest where+  type AsRPC Chest = Chest+instance HasRPCRepr ChestKey where+  type AsRPC ChestKey = ChestKey++----------------------------------------------------------------------------+-- MaybeRPC+----------------------------------------------------------------------------++-- | Represents a value that may or may not be in its RPC representation.+--+-- >>> :t NotRPC @(BigMap Integer MText) (mkBigMap @[(Integer, MText)] [])+-- ...+--   :: MaybeRPC (BigMap Integer MText)+--+-- >>> :t IsRPC @(BigMap Integer MText) (BigMapId 1)+-- ...+--   :: MaybeRPC (BigMap Integer MText)+data MaybeRPC v where+  NotRPC :: IsoValue  v => v -> MaybeRPC v+  IsRPC :: (SingI (ToT v), IsoValue (AsRPC v), HasRPCRepr v) => AsRPC v -> MaybeRPC v++instance HasNoOp (ToT v) => ToExpression (MaybeRPC v) where+  toExpression = \case+    NotRPC v -> toExpression (toVal v)+    IsRPC v -> withDict (rpcHasNoOpEvi @(ToT v)) $ toExpression (toVal v)++----------------------------------------------------------------------------+-- Derive RPC repr+----------------------------------------------------------------------------++-- | Derive an RPC representation for a type, as well as instances for 'Generic', 'IsoValue' and 'HasRPCRepr'.+--+-- > data ExampleStorage a b = ExampleStorage+-- >   { esField1 :: Integer+-- >   , esField2 :: [BigMap Integer MText]+-- >   , esField3 :: a+-- >   }+-- >   deriving stock Generic+-- >   deriving anyclass IsoValue+-- >+-- > deriveRPC "ExampleStorage"+--+-- Will generate:+--+-- > data ExampleStorageRPC a b = ExampleStorageRPC+-- >   { esField1RPC :: AsRPC Integer+-- >   , esField2RPC :: AsRPC [BigMap Integer MText]+-- >   , esField3RPC :: AsRPC a+-- >   }+-- >+-- > instance HasRPCRepr a => HasRPCRepr (ExampleStorage a b) where+-- >   type AsRPC (ExampleStorage a b) = ExampleStorageRPC a b+-- > deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b)+-- > instance Generic (ExampleStorageRPC a b) where+-- >   ...+deriveRPC :: String -> Q [Dec]+deriveRPC typeStr = deriveRPCWithStrategy typeStr haskellBalanced++-- | Recursively enumerate @data@, @newtype@ and @type@ declarations,+-- and derives an RPC representation for each type that doesn't yet have one.+--+-- You can also pass in a list of types for which you _don't_ want+-- an RPC representation to be derived.+--+-- In this example, 'deriveManyRPC' will generate an RPC+-- representation for @A@ and @B@,+-- but not for @C@ (because we explicitly said we don't want one)+-- or @D@ (because it already has one).+--+-- > data B = B+-- > data C = C+-- > data D = D+-- > deriveRPC "D"+-- >+-- > data A = A B C D+-- > deriveManyRPC "A" ["C"]+deriveManyRPC :: String -> [String] -> Q [Dec]+deriveManyRPC typeStr skipTypes =+  deriveManyRPCWithStrategy typeStr skipTypes haskellBalanced++-- | Same as 'deriveManyRPC', but uses a custom strategy for deriving a 'Generic' instance.+deriveManyRPCWithStrategy :: String -> [String] -> GenericStrategy -> Q [Dec]+deriveManyRPCWithStrategy typeStr skipTypes gs = do+  skipTypeNames <- traverse lookupTypeNameOrFail skipTypes+  typeName <- lookupTypeNameOrFail typeStr+  whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."+  allTypeNames <- findWithoutInstance typeName+  join <$> forM (allTypeNames List.\\ skipTypeNames) \name -> deriveRPCWithStrategy' name gs+  where++    -- | Recursively enumerate @data@, @newtype@ and @type@ declarations,+    -- and returns the names of only @data@ and @newtype@ of those that+    -- don't yet have an 'AsRPC' instance. Type aliases don't need instances+    -- and respectively there is no need to derive 'AsRPC' for them.+    findWithoutInstance :: Name -> Q [Name]+    findWithoutInstance typeName =+      fmap fst <$>+        reifyManyTyCons+          (\(name, dec) ->+            ifM (isTypeAlias name)+              (pure (False, decConcreteNames dec))+              (ifM (hasRPCInstance name)+                (pure (False, []))+                (pure (True, decConcreteNames dec)))+          )+          [typeName]++    hasRPCInstance :: Name -> Q Bool+    hasRPCInstance typeName = do+      deriveFullTypeFromName typeName >>= \case+        Nothing ->+          fail $ "Found a field with a type that is neither a 'data' nor a 'newtype' nor a 'type': "+            <> show typeName+        Just typ ->+          not . null <$> reifyInstances ''AsRPC [typ]++    -- | Given a type name, return the corresponding type expression+    -- (applied to any type variables, if necessary).+    --+    -- For example, assuming a data type like @data F a b = ...@ exists in the type environment,+    -- then @deriveFullTypeFromName ''F@ will return the type expression @[t|F a b|]@.+    --+    -- Note that only @data@, @newtype@ and @type@ declarations are supported at the moment.+    deriveFullTypeFromName :: Name -> Q (Maybe Type)+    deriveFullTypeFromName typeName = do+      typeInfo <- reify typeName+      case typeInfo of+        TyConI (DataD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars+        TyConI (NewtypeD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars+        TyConI (TySynD _ vars _) -> Just <$> deriveFullType typeName Nothing vars+        _ -> pure Nothing++-- | Same as 'deriveRPC', but uses a custom strategy for deriving a 'Generic' instance.+deriveRPCWithStrategy :: String -> GenericStrategy -> Q [Dec]+deriveRPCWithStrategy typeStr gs = do+  typeName <- lookupTypeNameOrFail typeStr+  whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."+  deriveRPCWithStrategy' typeName gs++deriveRPCWithStrategy' :: Name -> GenericStrategy -> Q [Dec]+deriveRPCWithStrategy' typeName gs = do+  (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName++  -- TODO: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`+  -- Print user-friendly error msg if it doesn't.+  let typeNameRPC = convertName typeName+  constructorsRPC <- traverse convertConstructor constructors+  fieldTypes <- getFieldTypes constructors+  fieldTypesRPC <- getFieldTypes constructorsRPC++  derivedType <- deriveFullType typeName mKind tyVars+  derivedTypeRPC <- deriveFullType typeNameRPC mKind tyVars++  -- Note: we can't use `makeRep0Inline` to derive a `Rep` instance for `derivedTypeRPC`+  -- It internally uses `reify` to lookup info about `derivedTypeRPC`, and because `derivedTypeRPC` hasn't+  -- been spliced *yet*, the lookup fails.+  -- So, instead, we fetch the `Rep` instance for `derivedType`, and+  -- append "RPC" to the type/constructor/field names in its metadata.+  --+  -- If, for some reason, we find out that this approach doesn't work for some edge cases,+  -- we should get rid of it and patch the @generic-deriving@ package to export a version of `makeRep0Inline`+  -- that doesn't use `reify` (it should be easy enough).+  repInstance <- reifyRepInstance typeName derivedType+  currentModuleName <- loc_module <$> location+  let repTypeRPC = convertRep currentModuleName repInstance+  typeDecOfRPC <- mkTypeDeclaration typeName decCxt typeNameRPC tyVars mKind constructorsRPC++  mconcat <$> sequence+    [ pure . one $ typeDecOfRPC+    , one <$> mkAsRPCInstance fieldTypes derivedType derivedTypeRPC+    , mkIsoValueInstance fieldTypesRPC derivedTypeRPC+    , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs+    ]++  where+    -- | Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@.+    convertFieldType :: Type -> Type+    convertFieldType tp = ConT ''AsRPC `AppT` tp++    convertNameStr :: String -> String+    convertNameStr s = s <> "RPC"++    convertName :: Name -> Name+    convertName = mkName . convertNameStr . nameBase++    -- | Given the constructor+    -- @C { f :: Int }@,+    -- returns the constructor+    -- @CRPC { fRPC :: AsRPC Int }@.+    convertConstructor :: Con -> Q Con+    convertConstructor = \case+      RecC conName fields -> pure $+        RecC+          (convertName conName)+          (fields <&> \(fieldName, fieldBang, fieldType) ->+            (convertName fieldName, fieldBang, convertFieldType fieldType)+          )+      NormalC conName fields -> pure $+        NormalC (convertName conName) (second convertFieldType <$> fields)+      InfixC fieldType1 conName fieldType2 -> pure $+        InfixC (second convertFieldType fieldType1) (convertName conName) (second convertFieldType fieldType2)+      constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show (ppr constr)++    -- | Get a list of all the unique types of all the fields of all the given constructors.+    getFieldTypes :: [Con] -> Q [Type]+    getFieldTypes constrs = ordNub . join <$> forM constrs \case+      RecC _ fields -> pure $ fields <&> \(_, _, fieldType) -> fieldType+      NormalC _ fields -> pure $ snd <$> fields+      InfixC field1 _ field2 -> pure [snd field1, snd field2]+      constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show (ppr constr)++    mkTypeDeclaration :: Name -> Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [Con] -> Q Dec+    mkTypeDeclaration tyName decCxt typeNameRPC tyVars mKind constructorsRPC = do+      typeInfo <- reify tyName+      case typeInfo of+        TyConI DataD {} -> pure $ DataD decCxt typeNameRPC tyVars mKind constructorsRPC []+        TyConI NewtypeD {} -> (case constructorsRPC of+          [con] -> pure $ NewtypeD decCxt typeNameRPC tyVars mKind con []+          _ -> fail "Newtype has only one constructor")+        _ -> fail $ "Only newtypes and data types are supported, but '" <>+          show tyName <> "' is:\n" <> show (ppr typeInfo)++    -- | Traverse a 'Rep' type and:+    --+    -- 1. Inspect its metadata and append @RPC@ to the type/constructor/field names.+    -- 2. Convert field types (e.g. @T@ becomes @AsRPC T@).+    -- 3. Replace the Rep's module name with the name of the module of where this Q is being spliced.+    convertRep :: String -> TySynEqn -> Type+    convertRep currentModuleName (TySynEqn _tyVars _lhs rhs) = go rhs+      where+        go :: Type -> Type+        go = \case+          -- Rename type name and module name+          PromotedT t `AppT` LitT (StrTyLit tyName) `AppT` LitT (StrTyLit _moduleName)+            | t == 'G.MetaData+            -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr tyName)) `AppT` LitT (StrTyLit currentModuleName)+          -- Rename constructor names+          PromotedT t `AppT` LitT (StrTyLit conName)+            | t == 'G.MetaCons+            -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr conName))+          -- Rename field names+          PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit fieldName))+            | t == 'G.MetaSel+            -> PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit (convertNameStr fieldName)))+          -- Replace field type @T@ with @AsRPC T@+          ConT x `AppT` fieldType+            | x == ''G.Rec0+            -> ConT x `AppT` convertFieldType fieldType+          x `AppT` y -> go x `AppT` go y+          x -> x++    -- | Lookup the generic 'Rep' type instance for the given type.+    reifyRepInstance :: Name -> Type -> Q TySynEqn+    reifyRepInstance name tp =+      reifyInstances ''G.Rep [tp] >>= \case+        [TySynInstD repInstance] -> pure repInstance+        (_:_) -> fail $ "Found multiple instances of 'Generic' for '" <> show name <> "'."+        [] -> fail $ "Type '" <> show name <> "' must implement 'Generic'."++    -- | Given the type @Foo a b = Foo (Bar a)@, generate an 'IsoValue' instance like:+    --+    -- > deriving anyclass instance IsoValue (AsRPC (Bar a)) => IsoValue (FooRPC a b)+    --+    -- Note that if a type variable @t@ is a phantom type variable, then no @IsoValue (AsRPC t)@+    -- constraint is generated for it.+    mkIsoValueInstance :: [Type] -> Type -> Q [Dec]+    mkIsoValueInstance fieldTypes tp =+      one <$> standaloneDerivWithStrategyD (Just AnyclassStrategy) constraints [t|IsoValue $(pure tp)|]+      where+        constraints :: Q Cxt+        constraints =+          cxt $ filter hasTyVar fieldTypes <&> \fieldType ->+            [t|IsoValue $(pure fieldType)|]++    -- | Given the type @Foo a b = Foo (Bar a)@, generate an 'HasRPCRepr' instance like:+    --+    -- > instance HasRPCRepr (Bar a) => HasRPCRepr (Foo a b) where+    -- >   type AsRPC (Foo a b) = FooRPC a b+    --+    -- Note that if a type variable @t@ is a phantom type variable, then no @HasRPCRepr@+    -- constraint is generated for it.+    mkAsRPCInstance :: [Type] -> Type -> Type -> Q Dec+    mkAsRPCInstance fieldTypes tp tpRPC = do+      typeInstance <- [d|type instance AsRPC $(pure tp) = $(pure tpRPC)|]+      instanceD constraints [t|HasRPCRepr $(pure tp)|]+        (pure <$> typeInstance)+      where+        constraints :: Q Cxt+        constraints =+          cxt $ filter hasTyVar fieldTypes <&> \fieldType ->+            [t|HasRPCRepr $(pure fieldType)|]++    -- | Checks if the given type has any type variables.+    hasTyVar :: Type -> Bool+    hasTyVar ty =+      flip any (universe ty) \case+        VarT _ -> True+        _ -> False++----------------------------------------------------------------------------+-- Conversions+----------------------------------------------------------------------------++-- | Replace all big_maps in a value with the respective big_map IDs.+--+-- Throws an error if it finds a big_map without an ID.+valueAsRPC :: HasCallStack => Value t -> Value (TAsRPC t)+valueAsRPC v =+  case v of+    VKey {} -> v+    VUnit {} -> v+    VSignature {} -> v+    VChainId {} -> v+    VChest {} -> v+    VChestKey {} -> v+    VOption (vMaybe :: Maybe (Value elem)) ->+      withDict (rpcSingIEvi @elem) $+        VOption $ valueAsRPC <$> vMaybe+    VList (vList :: [Value elem]) ->+      withDict (rpcSingIEvi @elem) $+        VList $ valueAsRPC <$> vList+    VSet {} -> v+    VOp {} -> v+    VContract {} -> v+    VTicket {} -> v+    VPair (x, y) -> VPair (valueAsRPC x, valueAsRPC y)+    VOr (vEither :: Either (Value l) (Value r)) ->+      withDict (rpcSingIEvi @l *** rpcSingIEvi @r) $+        case vEither of+          Right r -> VOr (Right (valueAsRPC r))+          Left l -> VOr (Left (valueAsRPC l))+    VLam {} -> v+    VMap (vMap :: Map (Value k) (Value v)) ->+      withDict (rpcSingIEvi @v) $+        VMap $ valueAsRPC <$> vMap+    VBigMap (Just bmId) _ -> VNat bmId+    VBigMap Nothing _ ->+      error $ unlines+        [ "Expected all big_maps to have an ID, but at least one big_map didn't."+        , "This is most likely a bug."+        ]+    VInt {} -> v+    VNat {} -> v+    VString {} -> v+    VBytes {} -> v+    VMutez {} -> v+    VBool {} -> v+    VKeyHash {} -> v+    VTimestamp {} -> v+    VAddress {} -> v+    VBls12381Fr {} -> v+    VBls12381G1 {} -> v+    VBls12381G2 {} -> v++-- | Replaces all bigmap IDs with their corresponding bigmap values.+-- This is the inverse of `valueAsRPC`.+replaceBigMapIds+  :: forall t m. Monad m+  => (forall k v. (SingI k, SingI v) => Natural -> m (Value ('TBigMap k v)))+  -- ^ A function for looking up a bigmap using its ID.+  -> Sing t -> Value (TAsRPC t) -> m (Value t)+replaceBigMapIds findBigMapById = go+  where+    go :: forall t1. Sing t1 -> Value (TAsRPC t1) -> m (Value t1)+    go s v = case (s, v) of+      (STKey {}, _) -> pure v+      (STUnit {}, _) -> pure v+      (STSignature {}, _) -> pure v+      (STChainId {}, _) -> pure v+      (STChest {}, _) -> pure v+      (STChestKey {}, _) -> pure v+      (STOption sMaybe, VOption vMaybe) ->+        withSingI sMaybe $+          VOption <$> traverse (go sMaybe) vMaybe+      (STList sList, VList vList) ->+        withSingI sList $+          VList <$> traverse (go sList) vList+      (STSet {}, _) -> pure v+      (STOperation {}, _) -> pure v+      (STContract {}, _) -> pure v+      (STTicket {}, _) -> pure v+      (STPair sa sb, VPair (a, b)) -> do+        a' <- go sa a+        b' <- go sb b+        pure $ VPair (a', b')+      (STOr sl sr, VOr vEither) -> withSingI sl $ withSingI sr $+        case vEither of+          Right r -> VOr . Right <$> go sr r+          Left l -> VOr . Left <$> go sl l+      (STLambda {}, _) -> pure v+      (STMap _ sv, VMap vList) ->+        withSingI sv $+          VMap <$> traverse (go sv) vList+      (STBigMap sk sv, VNat bigMapId) -> withSingI sk $ withSingI sv $ findBigMapById bigMapId+      (STInt {}, _) -> pure v+      (STNat {}, _) -> pure v+      (STString {}, _) -> pure v+      (STBytes {}, _) -> pure v+      (STMutez {}, _) -> pure v+      (STBool {}, _) -> pure v+      (STKeyHash {}, _) -> pure v+      (STTimestamp {}, _) -> pure v+      (STAddress {}, _) -> pure v+      (STBls12381Fr {}, _) -> pure v+      (STBls12381G1 {}, _) -> pure v+      (STBls12381G2 {}, _) -> pure v++-- | Replace all @big_map@ annotations in a value with @nat@ annotations.+notesAsRPC :: Notes t -> Notes (TAsRPC t)+notesAsRPC notes =+  case notes of+    NTKey {} -> notes+    NTUnit {} -> notes+    NTSignature {} -> notes+    NTChainId {} -> notes+    NTChest {} -> notes+    NTChestKey {} -> notes+    NTOption typeAnn elemNotes -> NTOption typeAnn $ notesAsRPC elemNotes+    NTList typeAnn elemNotes -> NTList typeAnn $ notesAsRPC elemNotes+    NTSet {} -> notes+    NTOperation {} -> notes+    NTContract {} -> notes+    NTTicket {} -> notes+    NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 notes1 notes2 ->+      NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 (notesAsRPC notes1) (notesAsRPC notes2)+    NTOr typeAnn fieldAnn1 fieldAnn2 notes1 notes2 ->+      NTOr typeAnn fieldAnn1 fieldAnn2 (notesAsRPC notes1) (notesAsRPC notes2)+    NTLambda {} -> notes+    NTMap typeAnn keyAnns valueNotes -> NTMap typeAnn keyAnns (notesAsRPC valueNotes)+    NTBigMap typeAnn _ _ -> NTNat typeAnn+    NTInt {} -> notes+    NTNat {} -> notes+    NTString {} -> notes+    NTBytes {} -> notes+    NTMutez {} -> notes+    NTBool {} -> notes+    NTKeyHash {} -> notes+    NTTimestamp {} -> notes+    NTAddress {} -> notes+    NTBls12381Fr {} -> notes+    NTBls12381G1 {} -> notes+    NTBls12381G2 {} -> notes+    NTNever {} -> notes+    NTSaplingState {} -> notes+    NTSaplingTransaction {} -> notes++----------------------------------------------------------------------------+-- Entailments+----------------------------------------------------------------------------++-- | A proof that if a singleton exists for @t@,+-- then so it does for @TAsRPC t@.+rpcSingIEvi :: forall (t :: T). SingI t :- SingI (TAsRPC t)+rpcSingIEvi =+  Sub $+    case sing @t of+      STKey -> Dict+      STUnit {} -> Dict+      STSignature {} -> Dict+      STChainId {} -> Dict+      STChest {} -> Dict+      STChestKey {} -> Dict+      STOption (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem+      STList (s :: Sing elem) -> withSingI s $  Dict \\ rpcSingIEvi @elem+      STSet (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem+      STOperation {} -> Dict+      STContract {} -> Dict+      STTicket {} -> Dict+      STPair (sa :: Sing a) (sb :: Sing b) ->+        withSingI sa $ withSingI sb $+          Dict \\ rpcSingIEvi @a \\ rpcSingIEvi @b+      STOr (sl :: Sing l) (sr :: Sing r) ->+        withSingI sl $ withSingI sr $+          Dict \\ rpcSingIEvi @l \\ rpcSingIEvi @r+      STLambda {} -> Dict+      STMap (sk :: Sing k) (sv :: Sing v) ->+        withSingI sk $ withSingI sv $+          Dict \\ rpcSingIEvi @k \\ rpcSingIEvi @v+      STBigMap {} -> Dict+      STInt {} -> Dict+      STNat {} -> Dict+      STString {} -> Dict+      STBytes {} -> Dict+      STMutez {} -> Dict+      STBool {} -> Dict+      STKeyHash {} -> Dict+      STBls12381Fr {} -> Dict+      STBls12381G1 {} -> Dict+      STBls12381G2 {} -> Dict+      STTimestamp {} -> Dict+      STAddress {} -> Dict+      STNever {} -> Dict+      STSaplingState _ -> Dict+      STSaplingTransaction _ -> Dict++-- | A proof that if @t@ is well-typed, then @TAsRPC t@ is also well-typed.+rpcWellTypedEvi :: forall (t :: T). WellTyped t => WellTyped t :- WellTyped (TAsRPC t)+rpcWellTypedEvi = rpcWellTypedEvi' sing++rpcWellTypedEvi'+  :: WellTyped t+  => Sing t+  -> WellTyped t :- WellTyped (TAsRPC t)+rpcWellTypedEvi' sng = Sub $ case sng of+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STOption s -> Dict \\ rpcWellTypedEvi' s+  STList s -> Dict \\ rpcWellTypedEvi' s+  STSet s -> Dict \\ rpcWellTypedEvi' s+  STOperation {} -> Dict+  STContract s -> Dict \\ rpcWellTypedEvi' s+  STTicket s -> Dict \\ rpcWellTypedEvi' s+  STPair sa sb -> Dict \\ rpcWellTypedEvi' sa \\ rpcWellTypedEvi' sb+  STOr sl sr -> Dict \\ rpcWellTypedEvi' sl \\ rpcWellTypedEvi' sr+  STLambda sa sb -> Dict \\ rpcWellTypedEvi' sa \\ rpcWellTypedEvi' sb+  STMap sk sv -> Dict \\ rpcWellTypedEvi' sk \\ rpcWellTypedEvi' sv+  STBigMap sk sv -> Dict \\ rpcWellTypedEvi' sk \\ rpcWellTypedEvi' sv+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STNever {} -> Dict+  STSaplingState _ -> Dict+  STSaplingTransaction _ -> Dict++-- | A proof that if @t@ does not contain any operations, then neither does @TAsRPC t@.+rpcHasNoOpEvi :: forall (t :: T). (SingI t, HasNoOp t) => HasNoOp t :- HasNoOp (TAsRPC t)+rpcHasNoOpEvi = rpcHasNoOpEvi' sing++rpcHasNoOpEvi'+  :: HasNoOp t+  => Sing t+  -> HasNoOp t :- HasNoOp (TAsRPC t)+rpcHasNoOpEvi' sng = Sub $ case sng of+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoOpEvi' s+  STList s -> Dict \\ rpcHasNoOpEvi' s+  STSet s -> Dict \\ rpcHasNoOpEvi' s+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> case checkOpPresence sa of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sa \\ rpcHasNoOpEvi' sb+  STOr sl sr -> case checkOpPresence sl of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sl \\ rpcHasNoOpEvi' sr+  STLambda {} -> Dict+  STMap _ sv -> case checkOpPresence sv of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict+  STSaplingState {} -> Dict+  STSaplingTransaction {} -> Dict++-- | A proof that @AsRPC (Value t)@ does not contain big_maps.+rpcHasNoBigMapEvi :: forall (t :: T). SingI t => Dict (HasNoBigMap (TAsRPC t))+rpcHasNoBigMapEvi = rpcHasNoBigMapEvi' (sing @t)++rpcHasNoBigMapEvi' :: Sing t -> Dict (HasNoBigMap (TAsRPC t))+rpcHasNoBigMapEvi' = \case+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoBigMapEvi' s+  STList s -> Dict \\ rpcHasNoBigMapEvi' s+  STSet s -> Dict \\ rpcHasNoBigMapEvi' s+  STOperation {} -> Dict+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> Dict \\ rpcHasNoBigMapEvi' sa \\ rpcHasNoBigMapEvi' sb+  STOr sl sr -> Dict \\ rpcHasNoBigMapEvi' sl \\ rpcHasNoBigMapEvi' sr+  STLambda {} -> Dict+  STMap sk sv -> Dict \\ rpcHasNoBigMapEvi' sk \\ rpcHasNoBigMapEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict+  STSaplingState {} -> Dict+  STSaplingTransaction {} -> Dict++-- | A proof that @AsRPC (Value t)@ does not contain big_maps.+rpcHasNoNestedBigMapsEvi+  :: forall (t :: T).+     SingI t+  => Dict (HasNoNestedBigMaps (TAsRPC t))+rpcHasNoNestedBigMapsEvi = rpcHasNoNestedBigMapsEvi' (sing @t)++rpcHasNoNestedBigMapsEvi' :: Sing t -> Dict (HasNoNestedBigMaps (TAsRPC t))+rpcHasNoNestedBigMapsEvi' = \case+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STList s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STSet s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STOperation {} -> Dict+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sa \\ rpcHasNoNestedBigMapsEvi' sb+  STOr sl sr ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sl \\ rpcHasNoNestedBigMapsEvi' sr+  STLambda {} -> Dict+  STMap sk sv ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sk \\ rpcHasNoNestedBigMapsEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict+  STSaplingState {} -> Dict+  STSaplingTransaction {} -> Dict++-- | A proof that if @t@ does not contain any contract values, then neither does @TAsRPC t@.+rpcHasNoContractEvi+  :: forall (t :: T).+     (SingI t, HasNoContract t)+  => HasNoContract t :- HasNoContract (TAsRPC t)+rpcHasNoContractEvi = rpcHasNoContractEvi' sing++rpcHasNoContractEvi'+  :: HasNoContract t+  => Sing t+  -> HasNoContract t :- HasNoContract (TAsRPC t)+rpcHasNoContractEvi' sng = Sub $ case sng of+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoContractEvi' s+  STList s -> Dict \\ rpcHasNoContractEvi' s+  STSet _ -> Dict+  STOperation {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> case checkContractTypePresence sa of+    ContractAbsent ->+      Dict \\ rpcHasNoContractEvi' sa \\ rpcHasNoContractEvi' sb+  STOr sl sr -> case checkContractTypePresence sl of+    ContractAbsent ->+      Dict \\ rpcHasNoContractEvi' sl \\ rpcHasNoContractEvi' sr+  STLambda {} -> Dict+  STMap _ sv -> Dict \\ rpcHasNoContractEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict+  STSaplingState {} -> Dict+  STSaplingTransaction {} -> Dict++-- | A proof that if @t@ is a valid storage type, then so is @TAsRPC t@.+rpcStorageScopeEvi :: forall (t :: T). StorageScope t :- StorageScope (TAsRPC t)+rpcStorageScopeEvi =+  Sub $ Dict+    \\ rpcSingIEvi @t+    \\ rpcHasNoOpEvi @t+    \\ rpcHasNoNestedBigMapsEvi @t+    \\ rpcHasNoContractEvi @t+    \\ rpcWellTypedEvi @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  {-# OPTIONS_GHC -Wno-orphans #-} @@ -31,17 +30,17 @@ import Options.Applicative   (footerDoc, fullDesc, header, help, helper, info, long, metavar, option, progDesc, strOption,   switch)-import qualified Options.Applicative as Opt+import Options.Applicative qualified as Opt import Options.Applicative.Help.Pretty (Doc) import Text.Read (read)  import Morley.Michelson.Parser (MichelsonSource(..))-import qualified Morley.Michelson.Parser as P+import Morley.Michelson.Parser qualified as P import Morley.Michelson.Runtime (TxData(..), TxParam(..)) import Morley.Michelson.Runtime.GState (genesisAddress) import Morley.Michelson.Text (MText) import Morley.Michelson.Untyped (EpName)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) import Morley.Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds) import Morley.Tezos.Crypto@@ -61,10 +60,10 @@   -> "parser" :! Opt.Parser s   -> Opt.ParserInfo s parserInfo-  (N usage)-  (N description)-  (N clientHeader)-  (N parser) =+  (arg #usage -> usage)+  (arg #description -> description)+  (arg #header -> clientHeader)+  (arg #parser -> parser) =   info (helper <*> parser) $   mconcat     [ fullDesc

@@ -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 Morley.Micheline   ( module Exports

@@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2020 Tocqueville Group--- SPDX-FileCopyrightText: 2018 obsidian.systems------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA -- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems  -- | Module that define encoding and decoding function from Expression type@@ -13,12 +12,12 @@   , encodeExpression'   ) where -import qualified Data.Binary.Builder as Bi-import qualified Data.Binary.Get as Bi-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Sequence as Seq-import qualified Unsafe (fromIntegral)+import Data.Binary.Builder qualified as Bi+import Data.Binary.Get qualified as Bi+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Sequence qualified as Seq+import Unsafe qualified (fromIntegral)  import Morley.Micheline.Binary.Internal import Morley.Micheline.Expression

@@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Tocqueville Group--- SPDX-FileCopyrightText: 2018 obsidian.systems------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA -- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems  -- | Defines binary encoding primitives which mimic Tezos' binary encoding.@@ -25,12 +24,12 @@   ) where  import Control.Exception (assert)-import qualified Data.Binary.Builder as Bi-import qualified Data.Binary.Get as Bi+import Data.Binary.Builder qualified as Bi+import Data.Binary.Get qualified as Bi import Data.Bits (Bits, bit, setBit, shift, testBit, zeroBits, (.&.), (.|.))-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Text.Encoding as TE-import qualified Unsafe (fromIntegral)+import Data.ByteString.Lazy qualified as LBS+import Data.Text.Encoding qualified as TE+import Unsafe qualified (fromIntegral)  newtype DynamicSize a = DynamicSize { unDynamicSize :: a } 

@@ -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 that provides type classes for converting to and from low-level -- Micheline representation.@@ -12,7 +11,7 @@  import Control.Lens ((<>~)) import Data.Bits (toIntegralSized)-import Data.Default+import Data.Default (def) import Data.Singletons (SingI(..), demote) import Fmt (Buildable(..), indentF, pretty, unlinesF) @@ -27,7 +26,7 @@   (Contract, HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType, rfAnyInstr,   toUType) import Morley.Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized)-import qualified Morley.Michelson.Untyped as Untyped+import Morley.Michelson.Untyped qualified as Untyped import Morley.Michelson.Untyped.Annotation   (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount,   emptyAnnSet, firstAnn, noAnn, secondAnn)@@ -74,7 +73,7 @@ instance ToExpression T where   toExpression = toExpression . toUType -instance SingI t => ToExpression (Notes t) where+instance ToExpression (Notes t) where   toExpression = toExpression . mkUType  instance ToExpression Untyped.T where@@ -116,6 +115,8 @@     Untyped.TChest -> PrimExpr "chest" [] []     Untyped.TChestKey -> PrimExpr "chest_key" [] []     Untyped.TNever -> PrimExpr "never" [] []+    Untyped.TSaplingState n -> PrimExpr "sapling_state" [naturalToExpr n] []+    Untyped.TSaplingTransaction n -> PrimExpr "sapling_transaction" [naturalToExpr n] []      where       addAnns :: Expression -> [Annotation] -> Expression@@ -229,6 +230,7 @@     ISNAT va -> PrimExpr "ISNAT" [] $ mkAnns [] [] [va]     ADD va -> PrimExpr "ADD" [] $ mkAnns [] [] [va]     SUB va -> PrimExpr "SUB" [] $ mkAnns [] [] [va]+    SUB_MUTEZ va -> PrimExpr "SUB_MUTEZ" [] $ mkAnns [] [] [va]     MUL va -> PrimExpr "MUL" [] $ mkAnns [] [] [va]     EDIV va -> PrimExpr "EDIV" [] $ mkAnns [] [] [va]     ABS va -> PrimExpr "ABS" [] $ mkAnns [] [] [va]@@ -286,9 +288,8 @@     OPEN_CHEST va -> PrimExpr "OPEN_CHEST" [] $ mkAnns [] [] [va]     NEVER -> PrimExpr "NEVER" [] []     EXT _ -> ExpressionSeq []-    where-      wordToExpr :: Word -> Expression-      wordToExpr = toExpression @(Value 'TInt) . VInt . fromIntegral @Word @Integer+    SAPLING_EMPTY_STATE va n -> PrimExpr "SAPLING_EMPTY_STATE" [naturalToExpr n] $ mkAnns [] [] [va]+    SAPLING_VERIFY_UPDATE va -> PrimExpr "SAPLING_VERIFY_UPDATE" [] $ mkAnns [] [] [va]  instance ToExpression Untyped.Contract where   toExpression contract@@ -608,6 +609,7 @@     PrimExpr "ISNAT" [] anns -> mkInstrWithVarAnn ISNAT anns     PrimExpr "ADD" [] anns -> mkInstrWithVarAnn ADD anns     PrimExpr "SUB" [] anns -> mkInstrWithVarAnn SUB anns+    PrimExpr "SUB_MUTEZ" [] anns -> mkInstrWithVarAnn SUB_MUTEZ anns     PrimExpr "MUL" [] anns -> mkInstrWithVarAnn MUL anns     PrimExpr "EDIV" [] anns -> mkInstrWithVarAnn EDIV anns     PrimExpr "ABS" [] anns -> mkInstrWithVarAnn ABS anns@@ -688,13 +690,6 @@     _ -> Left $ FromExpressionError e "Expected an instruction"      where-      intExprToWord :: Expression -> Either FromExpressionError Word-      intExprToWord n = do-        v <- fromExpression @(Value 'TInt) n-        case v of-          VInt n' -> maybeToRight (FromExpressionError n "Value is out of bounds")-            (toIntegralSized @Integer @Word n')-       mkInstrWithVarAnn         :: (VarAnn -> ExpandedInstr)         -> [Annotation]@@ -861,6 +856,12 @@     PrimExpr "chest" [] [] -> pure Untyped.TChest     PrimExpr "chest_key" [] [] -> pure Untyped.TChestKey     PrimExpr "never" [] [] -> pure Untyped.TNever+    PrimExpr "sapling_state" [n] [] -> do+      n' <- natExprToNatural n+      pure $ Untyped.TSaplingState n'+    PrimExpr "sapling_transaction" [n] [] -> do+      n' <- natExprToNatural n+      pure $ Untyped.TSaplingState n'     _ -> Left $ FromExpressionError e "Expected a type"     where       mkDoubleParamType@@ -946,7 +947,7 @@   -- Currently this error can't happen because parameter type   -- must be a Micheline primitive. If it ever changes, we   -- would like to notice it ASAP and update this place.-  _ -> error $ "parameter is not a primitive: " <> show expr+  _ -> error $ "parameter is not a primitive: " <> pretty expr  -- | Checks for a given expression that the number of annotations -- of each type in it doesn't exceed the specified threshold.@@ -973,3 +974,22 @@ forbidSingletonList = \case   _ :| [] -> Nothing   x       -> Just x++wordToExpr :: Word -> Expression+wordToExpr = toExpression @(Value 'TInt) . VInt . fromIntegral @Word @Integer++intExprToWord :: Expression -> Either FromExpressionError Word+intExprToWord n = do+  v <- fromExpression @(Value 'TInt) n+  case v of+    VInt n' -> maybeToRight (FromExpressionError n "Value is out of bounds")+      (toIntegralSized @Integer @Word n')++naturalToExpr :: Natural -> Expression+naturalToExpr = toExpression @(Value 'TNat) . VNat++natExprToNatural :: Expression -> Either FromExpressionError Natural+natExprToNatural n = do+  v <- fromExpression @(Value 'TNat) n+  case v of+    VNat n' -> Right n'

@@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2020 Tocqueville Group--- SPDX-FileCopyrightText: 2018 obsidian.systems------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA -- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems  {-# LANGUAGE DeriveLift #-}@@ -41,22 +40,22 @@   ) where  import Control.Lens (Plated)-import Control.Lens.TH+import Control.Lens.TH (makeLensesWith, makePrisms)  import Data.Aeson   (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:),   (.:?), (.=))-import qualified Data.Aeson.Encoding.Internal as Aeson-import qualified Data.Aeson.Types as Aeson+import Data.Aeson.Encoding.Internal qualified as Aeson+import Data.Aeson.Types qualified as Aeson import Data.Data (Data)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Sequence as Seq-import qualified Data.Text as T (uncons)+import Data.HashMap.Strict qualified as HashMap+import Data.Sequence qualified as Seq+import Data.Text qualified as T (uncons) import Fmt (Buildable(..), pretty, (+|), (|+))  import Language.Haskell.TH.Lift (Lift) import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation   (AnnotationSet(..), FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag,   annPrefix, fullAnnSet, minimizeAnnSet, mkAnnotation)@@ -108,7 +107,7 @@   "never", "NEVER", "UNPAIR", "VOTING_POWER", "TOTAL_VOTING_POWER", "KECCAK", "SHA3", "PAIRING_CHECK",   "bls12_381_g1", "bls12_381_g2", "bls12_381_fr", "sapling_state", "sapling_transaction", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket",   "TICKET", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST",-  "VIEW", "view", "constant"+  "VIEW", "view", "constant", "SUB_MUTEZ"   ]  -- | Type for Micheline Expression

@@ -14,16 +14,17 @@   ) where  import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON)-import qualified Data.Aeson.Encoding as AE-import qualified Data.Aeson.Types as Aeson+import Data.Aeson.Encoding qualified as AE+import Data.Aeson.Types qualified as Aeson import Data.Bits (Bits) import Data.Typeable (typeRep) import Fmt (Buildable(..))-import qualified Text.Show as T+import Text.Show qualified as T  import Morley.Tezos.Core (Mutez(..), mkMutez)+import Unsafe qualified (unsafeM) -printAsString :: Show a => a -> Aeson.Value+printAsString :: (PrettyShow a, Show a) => a -> Aeson.Value printAsString a = Aeson.String $ show a  parseAsString :: forall a. (Read a, Typeable a) => Aeson.Value -> Aeson.Parser a@@ -54,7 +55,7 @@   parseJSON = parseStringEncodedIntegral  instance Buildable TezosInt64 where-  build = show+  build = show . unStringEncode  instance ToJSON TezosInt64 where   toJSON (StringEncode x) = Aeson.String $ show x@@ -68,13 +69,14 @@  instance FromJSON TezosMutez where   parseJSON v = do-    i <- parseAsString @Int64 v-    either (fail . toString) (pure . TezosMutez) $ mkMutez i+    i     <- parseAsString @Int64 v+    mutez <- Unsafe.unsafeM $ mkMutez i+    pure $ TezosMutez mutez  type TezosNat = StringEncode Natural  instance Buildable TezosNat where-  build = show+  build = show . unStringEncode  instance ToJSON TezosNat where   toJSON (StringEncode x) = Aeson.String $ show x

@@ -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  -- | Static analysis of Michelson code. @@ -10,10 +9,10 @@   ) where  import Data.Default (def)-import qualified Data.HashMap.Strict as HM-import qualified Data.List.NonEmpty as NE+import Data.HashMap.Strict qualified as HM+import Data.List.NonEmpty qualified as NE import Fmt (Buildable(..), Builder, blockMapF', hexF, nameF, (+|))-import qualified Unsafe (fromIntegral)+import Unsafe qualified (fromIntegral)  import Morley.Michelson.FailPattern import Morley.Michelson.Text (MText)

@@ -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 TypeFamilyDependencies, UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}@@ -44,6 +43,7 @@   , buildDoc   , buildMarkdownDoc   , modifyDoc+  , docBlockToMarkdown    , DGeneralInfoSection (..)   , DName (..)@@ -61,18 +61,18 @@   , attachDocCommons   ) where -import qualified Data.Map as M-import qualified Data.Map.Merge.Strict as M-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT+import Data.Map qualified as M+import Data.Map.Merge.Strict qualified as M+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Text.Lazy qualified as LT import Data.Typeable (cast, typeRep) import Development.GitRev (gitCommitDate, gitHash)-import Fmt (Buildable, build, fmt, (+|), (+||), (|+), (||+))-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Lift as TH+import Fmt (Buildable, build, fmt, (+|), (|+))+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Lift qualified as TH import System.Environment (lookupEnv)-import qualified Text.Show+import Text.Show qualified  import Morley.Util.Instances () import Morley.Util.Lens@@ -337,7 +337,8 @@   where     onTypeMismatch =       error $ "appending doc sections for doc items of different types:"-              +|| typeRep (Proxy @d1) ||+ " and " +|| typeRep (Proxy @d2) ||+ ""+              +| show @Text (typeRep (Proxy @d1)) |+ " and "+              +| show @Text (typeRep (Proxy @d2)) |+ ""  -- | A map from positions to document elements. --@@ -445,7 +446,7 @@ lookupDocBlockSection block = do   DocSection (ds :: NonEmpty (DocElem d')) <- M.lookup (docItemPosition @d) block   case eqT @d @d' of-    Nothing -> error $ "Invalid DocBlock: item of type " +|| typeRep (Proxy @d) ||+ " \+    Nothing -> error $ "Invalid DocBlock: item of type " +| show @Text (typeRep (Proxy @d)) |+ " \                        \under position " +| docItemPosition @d |+ ""     Just Refl -> pure $ map deItem ds @@ -717,7 +718,7 @@               \environmental variable."             return Nothing           TH.LitE (TH.StringL str) -> return (Just str)-          value -> error $ "Unknown value returned by git: " <> show value+          value -> error $ "Unknown value returned by git: " <> show (TH.ppr value)  instance DocItem DGitRevision where   docItemPos = 2

@@ -1,10 +1,8 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  module Morley.Michelson.ErrorPos   ( mkPos-  , unsafeMkPos   , Pos (..)   , SrcPos (..)   , srcPos@@ -13,33 +11,27 @@   , LetName (..)   ) where +import Unsafe qualified (fromIntegral)+ import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..)) import Data.Default (Default(..))-import qualified Data.Text as T+import Data.Text qualified as T import Fmt (Buildable(..)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDocExtended, renderAnyBuildable)-import Text.PrettyPrint.Leijen.Text-import qualified Unsafe (fromIntegral)-+import Text.PrettyPrint.Leijen.Text (list, (<+>))  import Morley.Util.Aeson - newtype Pos = Pos {unPos :: Word}   deriving stock (Eq, Ord, Show, Generic, Data)  instance NFData Pos -unsafeMkPos :: Int -> Pos-unsafeMkPos x-  | x < 0     = error $ "negative pos: " <> show x-  | otherwise = Pos $ Unsafe.fromIntegral @Int @Word x--mkPos :: Int -> Maybe Pos+mkPos :: Int -> Either Text Pos mkPos x-  | x < 0     = Nothing-  | otherwise = Just $ Pos $ Unsafe.fromIntegral @Int @Word x+  | x < 0     = Left $ "negative pos: " <> show x+  | otherwise = Right $ Pos $ Unsafe.fromIntegral @Int @Word x  data SrcPos =   SrcPos@@ -72,7 +64,7 @@     "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))     <> case icsCallStack of          [] -> "."-         _ -> " inside these let defenitions:" <+> (list $ fmap (text . show) icsCallStack) <> "."+         _ -> " inside these let defenitions:" <+> (list $ fmap renderAnyBuildable icsCallStack) <> "."  instance Buildable InstrCallStack where   build = buildRenderDocExtended

@@ -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  -- NOTE this pragmas. -- We disable some wargnings for the sake of speed up.@@ -27,7 +26,7 @@ data TypicalFailWith   = FailWithString MText   -- ^ Push a constant string and fail with it.-  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope)+  | FailWithConstantPair MText SomeConstant   -- ^ Push a constant pair where the first item is a string and the   -- second one is an arbitrary constant. Fail afterwards.   | FailWithStackValue MText@@ -69,7 +68,7 @@   | VPair (VString str, secondItem) <- v =       -- We need to pattern match to deduce `singI` for second item of the pair.       case sing @t of-        STPair l r -> withSingI l $ withSingI r $ Just (FailWithConstantPair str (SomeConstrainedValue secondItem))+        STPair l r -> withSingI l $ withSingI r $ Just (FailWithConstantPair str (SomeConstant secondItem))   | otherwise = Nothing  -- | If given instruction ends with a typical 'FAILWITH' usage, modify@@ -77,7 +76,7 @@ -- return any value, not necessarily a string. modifyTypicalFailWith   :: HasCallStack-  => (MText -> SomeConstrainedValue ConstantScope)+  => (MText -> SomeConstant)   -> Instr inp out   -> Instr inp out modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft@@ -98,7 +97,7 @@               , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->                 case sing @('TPair a b) of                   STPair l r -> withSingI l $ withSingI r $ case isStringValue v of-                    Just (f -> SomeConstrainedValue v') ->+                    Just (f -> SomeConstant v') ->                       PUSH v' `Seq` PAIR `Seq` FAILWITH                     Nothing ->                       PUSH v `Seq` PAIR `Seq` FAILWITH@@ -107,7 +106,7 @@               , _ :: Instr s0 ('TPair a b ': s) <- i1 ->                 case sing @('TPair a b) of                   STPair l r -> withSingI l $ withSingI r $ Seq i0 $ case isStringValue v of-                    Just (f -> SomeConstrainedValue v') ->+                    Just (f -> SomeConstant v') ->                       PUSH v' `Seq` PAIR `Seq` FAILWITH                     Nothing ->                       PUSH v `Seq` PAIR `Seq` FAILWITH@@ -119,8 +118,8 @@     onPush ::       (HasCallStack, ConstantScope v) => Value v -> Instr inp out     onPush v = case isTypicalErrorConstant v of-      Just (FailWithString (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH-      Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->+      Just (FailWithString (f -> SomeConstant v')) -> PUSH v' `Seq` FAILWITH+      Just (FailWithConstantPair (f -> SomeConstant v') (SomeConstant arg)) ->         PUSH (VPair (v', arg)) `Seq` FAILWITH       Just _ -> error "Unexpected TypicalFailWith"       Nothing -> PUSH v `Seq` FAILWITH

@@ -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, containing function to interpret Michelson -- instructions against given context and input stack. module Morley.Michelson.Interpret@@ -50,13 +52,13 @@ import Control.Monad.RWS.Strict (RWS, RWST, runRWS) import Control.Monad.Writer (MonadWriter, WriterT, tell) import Data.Default (Default(..))-import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.Map qualified as Map+import Data.Set qualified as Set import Data.Singletons.Decide (decideEquality) import Data.Vinyl (Rec(..), (<+>)) import Data.Vinyl.Recursive (rmap)-import Fmt (Buildable(build), blockListF, pretty, prettyLn)-import qualified Unsafe (fromIntegral)+import Fmt (Buildable(build), blockListF, pretty, prettyLn, (+|), (|+))+import Unsafe qualified (fromIntegral)  import Morley.Michelson.ErrorPos (InstrCallStack(..)) import Morley.Michelson.Interpret.Pack (packValue')@@ -64,10 +66,10 @@ import Morley.Michelson.Runtime.GState import Morley.Michelson.TypeCheck (matchTypes) import Morley.Michelson.Typed hiding (Branch(..))-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation   (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation (annQ) import Morley.Tezos.Address (Address(..), GlobalCounter(..)) import Morley.Tezos.Core (ChainId, Mutez, Timestamp, zeroMutez)@@ -175,10 +177,11 @@ data MichelsonFailed where   MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed   MichelsonArithError-    :: (Typeable n, Typeable m, Typeable instr)-    => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed+    :: (Typeable n, Typeable m)+    => ArithError (Value n) (Value m) -> MichelsonFailed   MichelsonGasExhaustion :: MichelsonFailed   MichelsonFailedTestAssert :: Text -> MichelsonFailed+  MichelsonUnsupported :: Text -> MichelsonFailed  deriving stock instance Show MichelsonFailed @@ -191,16 +194,20 @@   MichelsonGasExhaustion == _ = False   MichelsonFailedTestAssert t1 == MichelsonFailedTestAssert t2 = t1 == t2   MichelsonFailedTestAssert _ == _ = False+  MichelsonUnsupported i1 == MichelsonUnsupported i2 = i1 == i2+  MichelsonUnsupported _ == _ = False  instance Buildable MichelsonFailed where   build =     \case       MichelsonFailedWith v ->-        "Reached FAILWITH instruction with " <> build v+        "Reached FAILWITH instruction with " +| v |+ ""       MichelsonArithError v -> build v       MichelsonGasExhaustion ->         "Gas limit exceeded on contract execution"       MichelsonFailedTestAssert t -> build t+      MichelsonUnsupported instr ->+        build instr <> " instruction is not supported."  -- | Carries a 'MichelsonFailed' error and the 'InstrCallStack' at which it was raised data MichelsonFailureWithStack = MichelsonFailureWithStack@@ -495,8 +502,10 @@     go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a        => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out     go Zero stack = stack-    go (Succ n') (b :& r) = case go n' r of-      (a :& resTail) -> a :& b :& resTail+    go (Succ n') (b :& r) =+      case klist @inp of+        KCons _ Proxy -> case go n' r of+          (a :& resTail) -> a :& b :& resTail runInstrImpl _ (DUG s) input0 =   pure $ go s input0   where@@ -667,6 +676,7 @@   else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r+runInstrImpl _ SUB_MUTEZ (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @SubMutez) l r runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r runInstrImpl _ EDIV (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @EDiv) l r runInstrImpl _ ABS ((seValue -> a) :& rest) =@@ -883,6 +893,8 @@           BogusCipher   -> VOr (Right (VBool False))         Left _ -> VOr (Right (VBool True))   pure $ starNotesStkEl result :& r+runInstrImpl _ (SAPLING_EMPTY_STATE _) _ = throwMichelson $ MichelsonUnsupported "SAPLING_EMPTY_STATE"+runInstrImpl _ SAPLING_VERIFY_UPDATE _ = throwMichelson $ MichelsonUnsupported "SAPLING_VERIFY_UPDATE"  -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp@@ -965,17 +977,22 @@ assignBigMapIds' :: EvalM m => Value t -> m (Value t) assignBigMapIds' val = do   bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState-  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds val) bigMapCounter0+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds True val) bigMapCounter0   modifyInterpreterState (set isBigMapCounterL bigMapCounter1)   pure storageWithIds  -- | All big_maps stored in a chain have a globally unique ID. -- -- We use this function to assign a new ID whenever a big_map is created.-assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)-assignBigMapIds =+assignBigMapIds+  :: (MonadState BigMapCounter m)+  => Bool+  -- ^ If true, assign a new ID even if the bigmap already has one.+  -- Otherwise, assign IDs only to bigmaps that don't have one yet.+  -> Value t -> m (Value t)+assignBigMapIds overwriteExistingId =   dfsTraverseValue \case-    VBigMap _ vBigMap -> do+    VBigMap existingId vBigMap | overwriteExistingId || isNothing existingId -> do       bigMapId <- bigMapCounter <<+= 1       pure $ VBigMap (Just bigMapId) vBigMap     v -> pure 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, carrying logic of @PACK@ instruction. --

@@ -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, carrying logic of @UNPACK@ instruction. @@ -24,16 +23,16 @@  import Prelude hiding (EQ, Ordering(..), get) -import qualified Data.ByteString as BS+import Data.ByteString qualified as BS import Data.Constraint (Dict(..)) import Fmt (pretty)  import Morley.Micheline.Binary (eitherDecodeExpression) import Morley.Micheline.Class (FromExpression(..)) import Morley.Michelson.Typed (UnpackedValScope)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Util.Binary  {- Implementation notes:

@@ -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  -- | General utilities used by interpreter. --@@ -10,8 +9,8 @@   ) where  import Control.Exception (assert)-import qualified Data.Bits as Bits-import qualified Unsafe (fromIntegral)+import Data.Bits qualified as Bits+import Unsafe qualified (fromIntegral)  -- | Encode a number as tezos does this. --

@@ -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 Morley.Michelson.Let   ( LetType (..)@@ -8,7 +7,7 @@   ) where  import Data.Aeson.TH (deriveJSON)-import qualified Data.Text as T+import Data.Text qualified as T  import Morley.Michelson.Macro (ParsedOp) import Morley.Michelson.Untyped (Ty, Value')@@ -20,6 +19,8 @@   , lvSig :: Ty   , lvVal :: (Value' ParsedOp)   } deriving stock (Eq, Show)++{-# DEPRECATED LetValue, LetType "Let macros are deprecated" #-}  -- | A programmer-defined type-synonym data LetType = LetType

@@ -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 Morley.Michelson.Macro   (   -- * Macros types@@ -39,8 +41,8 @@  import Data.Aeson.TH (deriveJSON) import Data.Data (Data(..))-import qualified Data.Text as T-import Fmt (Buildable(build), GenericBuildable(..), (+|), (+||), (|+), (||+))+import Data.Text qualified as T+import Fmt (Buildable(build), GenericBuildable(..), (+|), (|+))  import Morley.Michelson.ErrorPos import Morley.Michelson.Printer (RenderDoc(..))@@ -58,6 +60,8 @@   deriving stock (Eq, Show, Data, Generic)   deriving Buildable via GenericBuildable LetMacro +{-# DEPRECATED LetMacro "Let macros are deprecated" #-}+ instance NFData LetMacro  data PairStruct@@ -115,6 +119,10 @@  type ParsedValue = Value' ParsedOp +{-# DEPRECATED+  CASE, TAG, ACCESS, SET, CONSTRUCT, VIEW_, VOID+  "Morley-specific macros are deprecated" #-}+ -- | Built-in Michelson Macros defined by the specification data Macro   = CASE (NonEmpty [ParsedOp])@@ -151,10 +159,10 @@  instance Buildable Macro where   build = \case-    TAG idx ty -> "<TAG: #"+||idx||+" from "+|toList ty|+""+    TAG idx ty -> "<TAG: #"+|idx|+" from "+|toList ty|+""     CASE parsedInstrs -> "<CASE: "+|toList parsedInstrs|+">"-    ACCESS idx size -> "<ACCESS: #"+||idx||+"/"+|size|+""-    SET idx size -> "<SET: #"+||idx||+"/"+|size|+""+    ACCESS idx size -> "<ACCESS: #"+|idx|+"/"+|size|+""+    SET idx size -> "<SET: #"+|idx|+"/"+|size|+""     CONSTRUCT parsedInstrs -> "<CONSTRUCT: "+|toList parsedInstrs|+">"     VIEW_ code -> "<VIEW_: "+|code|+">"     VOID code -> "<VOID: "+|code|+">"@@ -165,8 +173,8 @@     PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"     UNPAPAIR pairStruct -> "<UNPAPAIR: "+|pairStruct|+">"     CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"-    CARN varAnn idx -> "<CAR: #"+||idx||+","+||varAnn||+">"-    CDRN varAnn idx -> "<CDR: #"+||idx||+","+||varAnn||+">"+    CARN varAnn idx -> "<CAR: #"+|idx|+","+|varAnn|+">"+    CDRN varAnn idx -> "<CDR: #"+|idx|+","+|varAnn|+">"     SET_CADR cadrStructs varAnn fieldAnn -> "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"     MAP_CADR cadrStructs varAnn fieldAnn parsedOps -> "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"     DIIP integer parsedOps -> "<DIIP: "+|integer|+", "+|parsedOps|+">"

@@ -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  -- NOTE this pragmas. -- We disable some wargnings for the sake of speed up.@@ -8,6 +7,9 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-} +-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-deprecations #-}+ -- | Optimizer for typed instructions. -- -- It's quite experimental and incomplete.@@ -28,9 +30,11 @@ import Prelude hiding (EQ, GT, LT)  import Control.Lens (makeLensesFor)-import Data.Constraint (Dict(..))+import Data.Constraint (Dict(..), (\\)) import Data.Default (Default(def)) import Data.Singletons (sing)+import Data.Type.Equality ((:~:)(Refl))+import Unsafe.Coerce (unsafeCoerce)  import Morley.Michelson.Interpret.Pack (packValue') import Morley.Michelson.Typed.Aliases (Value)@@ -39,9 +43,11 @@ import Morley.Michelson.Typed.Scope (ConstantScope, PackedValScope, checkScope) import Morley.Michelson.Typed.Sing import Morley.Michelson.Typed.T-import Morley.Michelson.Typed.Util (DfsSettings(..), dfsInstr)+import Morley.Michelson.Typed.Util (DfsSettings(..), dfsModifyInstr) import Morley.Michelson.Typed.Value+import Morley.Util.Peano import Morley.Util.PeanoNatural+import Morley.Util.Type  ---------------------------------------------------------------------------- -- High level@@ -75,10 +81,8 @@ optimizeWithConf (OptimizerConf ocGotoValues rules) instr = foldl (flip performOneStage) instrRHS rules   where     dfsSettings = def{ dsGoToValues = ocGotoValues }-    performOneStage stageRules = (fst .)-      $ dfsInstr dfsSettings-      $ (adapter .)-      $ applyOnce stageRules+    performOneStage stageRules =+      dfsModifyInstr dfsSettings $ applyOnce stageRules     instrRHS = applyOnce (fixpoint flattenSeqLHS) instr  ----------------------------------------------------------------------------@@ -130,8 +134,12 @@     `orSimpleRule` simpleDrops     `orSimpleRule` internalNop     `orSimpleRule` simpleDips+    `orSimpleRule` simpleDups     `orSimpleRule` adjacentDips     `orSimpleRule` isSomeOnIf+    `orSimpleRule` redundantIf+    `orSimpleRule` emptyDip+    `orSimpleRule` digDug     `orSimpleRule` specificPush     `orSimpleRule` pairUnpair     `orSimpleRule` pairMisc@@ -359,6 +367,14 @@    _ -> Nothing +simpleDups :: Rule+simpleDups = Rule $ \case+  -- DUP 1 is just DUP+  DUPN One :# xs -> Just $ DUP :# xs+  DUPN One -> Just $ DUP++  _ -> Nothing+ adjacentDips :: Rule adjacentDips = Rule $ \case   DIP f :# DIP g -> Just (DIP (f :# g))@@ -366,6 +382,62 @@    _ -> Nothing +redundantIf :: Rule+redundantIf = Rule \case+  IF x y :# xs+    | x == y+    -> Just $ DROP :# x :# xs+  IF x y+    | x == y+    -> Just $ DROP :# x+  _ -> Nothing++emptyDip :: Rule+emptyDip = Rule \case+  DIP Nop :# xs -> Just xs+  DIP Nop -> Just Nop+  DIPN _ Nop :# xs -> Just xs+  DIPN _ Nop -> Just Nop+  _ -> Nothing++digDug :: Rule+digDug = Rule \case+  (DIG (x :: PeanoNatural n) :: Instr inp t) :# (DUG y :: Instr t out) :# xs+    | Just Refl <- eqPeanoNat x y+    -> Just xs \\ digDugProof @inp @out @t @n (singPeanoNat x)+  (DIG (x :: PeanoNatural n) :: Instr inp t) :# (DUG y :: Instr t out)+    | Just Refl <- eqPeanoNat x y+    -> Just Nop \\ digDugProof @inp @out @t @n (singPeanoNat x)+  _ -> Nothing++digDugProof+  :: forall inp out t n a.+     ( KnownList inp+     , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))+     , t ~ (a ': Take n inp ++ Drop ('S n) inp)+     , out ~ (Take n (Drop ('S 'Z) t) ++ (a ': Drop ('S n) t))+     )+  => SingNat n -> inp :~: out+{-# RULES "digDugProof" forall n. digDugProof n = unsafeCoerce Refl #-}+{-# INLINE[1] digDugProof #-}+digDugProof n = Refl+  \\ lemma1 n inpS+  \\ lemma2 n inpS+  where+    inpS = klist @inp+    lemma1 :: forall xs m. SingNat m -> KList xs -> Take m xs :~: Take m (Take m xs ++ Drop ('S m) xs)+    lemma1 = \case+      SZ -> const Refl+      SS m -> \case+        KNil -> Refl+        KCons _ (Proxy :: Proxy ys) -> Refl \\ lemma1 m (klist @ys)+    lemma2 :: forall xs m. SingNat m -> KList xs -> Drop ('S m) xs :~: Drop m (Take m xs ++ Drop ('S m) xs)+    lemma2 = \case+      SZ -> const Refl+      SS m -> \case+        KNil -> Refl+        KCons _ (Proxy :: Proxy ys) -> lemma2 m (klist @ys)+ -- TODO (#299): optimize sequences of more than 2 DROPs. -- | Sequences of @DROP@s can be turned into single @DROP n@. -- When @n@ is greater than 2 it saves size and gas.@@ -553,6 +625,7 @@   CONCAT       :# DROP :# c -> Just $ DROP :# DROP :# c   ADD          :# DROP :# c -> Just $ DROP :# DROP :# c   SUB          :# DROP :# c -> Just $ DROP :# DROP :# c+  SUB_MUTEZ    :# DROP :# c -> Just $ DROP :# DROP :# c   MUL          :# DROP :# c -> Just $ DROP :# DROP :# c   EDIV         :# DROP :# c -> Just $ DROP :# DROP :# c   OR           :# DROP :# c -> Just $ DROP :# DROP :# c@@ -570,6 +643,7 @@   CONCAT       :# DROP      -> Just $ DROP :# DROP   ADD          :# DROP      -> Just $ DROP :# DROP   SUB          :# DROP      -> Just $ DROP :# DROP+  SUB_MUTEZ    :# DROP      -> Just $ DROP :# DROP   MUL          :# DROP      -> Just $ DROP :# DROP   EDIV         :# DROP      -> Just $ DROP :# DROP   OR           :# DROP      -> Just $ DROP :# DROP@@ -622,10 +696,6 @@ -- | Apply the rule once, if it fails, return the instruction unmodified. applyOnce :: Rule -> Instr inp out -> Instr inp out applyOnce r i = maybe i id (unRule r $ i)---- | An adapter for `dfsInstr`.-adapter :: a -> (a, ())-adapter a = (a, ())  -- | Apply a rule to the same code, until it fails. whileApplies :: Rule -> Rule

@@ -1,13 +1,16 @@--- 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 -Wno-redundant-constraints #-}+ module Morley.Michelson.Parser   ( -- * Main parser type     Parser    -- * Parsers   , program+  , programExt   , value    -- * Errors@@ -38,6 +41,7 @@   -- * Quoters   , utypeQ   , uparamTypeQ+  , notes    -- * Re-exports   , errorBundlePretty@@ -45,17 +49,18 @@  import Prelude hiding (try) -import Fmt (pretty)-import qualified Language.Haskell.TH.Lift as TH-import qualified Language.Haskell.TH.Quote as TH+import Data.Default (Default(..))+import Fmt (pretty, (+|), (|+))+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Lift qualified as TH+import Language.Haskell.TH.Quote qualified as TH import Text.Megaparsec   (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,   parse, sepEndBy, try) import Text.Megaparsec.Pos (SourcePos(..), unPos) -import Morley.Michelson.ErrorPos (SrcPos(..), unsafeMkPos)-import Morley.Michelson.Macro-  (LetMacro, Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue)+import Morley.Michelson.ErrorPos (SrcPos(..), mkPos)+import Morley.Michelson.Macro (Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue) import Morley.Michelson.Parser.Annotations (noteF) import Morley.Michelson.Parser.Common import Morley.Michelson.Parser.Error@@ -67,8 +72,9 @@ import Morley.Michelson.Parser.Type import Morley.Michelson.Parser.Types import Morley.Michelson.Parser.Value+import Morley.Michelson.Typed.Extract (withUType) import Morley.Michelson.Untyped-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U  ---------------------------------------------------------------------------- -- Helpers@@ -76,11 +82,12 @@  -- | Parse with empty environment parseNoEnv ::-     Parser a+     Default le+  => Parser' le a   -> MichelsonSource   -> Text   -> Either (ParseErrorBundle Text CustomParserException) a-parseNoEnv p src = parse (runReaderT p noLetEnv <* eof) (pretty src)+parseNoEnv p src = parse (runReaderT p def <* eof) (pretty src)  ------------------------------------------------------------------------------- -- Parsers@@ -89,20 +96,27 @@ -- Contract ------------------ --- | Michelson contract with let definitions+-- | Michelson contract program :: Parsec CustomParserException Text (Contract' ParsedOp)-program = runReaderT programInner noLetEnv <* eof-  where-    programInner :: Parser (Contract' ParsedOp)-    programInner = do-      mSpace-      env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))-      local (const env) contract+program = runReaderT (programInner @()) def <* eof -cbParameter :: Parser ParameterType-cbParameter = symbol "parameter" *> cbParameterBare+programInner+  :: forall env. (Default env)+  => Parser env (Contract' ParsedOp)+programInner = do+  mSpace+  env <- fromMaybe def <$> (optional (letBlock parsedOp))+  local (const env) contract -cbParameterBare :: Parser ParameterType+-- TODO [#712]: Remove this next major release+-- | Michelson contract with let definitions+programExt :: Parsec CustomParserException Text (Contract' ParsedOp)+programExt = runReaderT (programInner @LetEnv) def <* eof++cbParameter :: Parser le ParameterType+cbParameter = symbol1 "parameter" *> cbParameterBare++cbParameterBare :: Parser le ParameterType cbParameterBare = do   prefixRootAnn <- optional noteF   (inTypeRootAnn, t) <- field@@ -115,13 +129,13 @@     (Just _, _) -> customFailure MultiRootAnnotationException   pure $ ParameterType t rootAnn -cbStorage :: Parser Ty-cbStorage = symbol "storage" *> type_+cbStorage :: Parser le Ty+cbStorage = symbol1 "storage" *> type_ -cbCode :: Parser [ParsedOp]+cbCode :: Parser le [ParsedOp] cbCode = symbol "code" *> codeEntry -cbView :: Parser (View' ParsedOp)+cbView :: Parser le (View' ParsedOp) cbView = do   symbol "view"   viewName <- viewName_@@ -130,7 +144,7 @@   viewCode <- ops   return View{..} -contractBlock :: Parser (ContractBlock ParsedOp)+contractBlock :: Parser le (ContractBlock ParsedOp) contractBlock = choice   [ (CBParam <$> cbParameter)   , (CBStorage <$> cbStorage)@@ -139,21 +153,21 @@   ]  -- | This ensures that the error message will point to the correct line.-ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()+ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le () ensureNotDuplicate blocks result =   let-    failDuplicateField a = fail $ "Duplicate contract field: " <> a+    failDuplicateField a = fail $ "Duplicate contract field: " +| a |+ ""   in     case (result, blocks) of-      (CBParam _, CBParam _ : _) -> failDuplicateField "parameter"-      (CBStorage _, CBStorage _: _) -> failDuplicateField "storage"-      (CBCode _, CBCode _: _) -> failDuplicateField "code"+      (CBParam _, CBParam _ : _) -> failDuplicateField result+      (CBStorage _, CBStorage _: _) -> failDuplicateField result+      (CBCode _, CBCode _: _) -> failDuplicateField result       (CBView _, _) -> pure ()       (_, _:xs) -> ensureNotDuplicate xs result       (_, []) -> pure ()  -- | Michelson contract-contract :: Parser (Contract' ParsedOp)+contract :: Parser le (Contract' ParsedOp) contract = do   mSpace   result <- braces contractTuple <|> contractTuple@@ -161,7 +175,7 @@     Just contract' ->       return contract'     Nothing ->-      fail $ "Duplicate contract field: " <> show result+      fail $ "Duplicate contract field: " <> pretty result   where     -- | @ensureNotDuplicate@ provides a better message and point to the correct line     -- when the parser fails.@@ -174,15 +188,15 @@ -- Value ------------------ -value :: Parser ParsedValue+value :: Parser le ParsedValue value = value' parsedOp  -- | Parse untyped value from text which comes from something that is -- not a file (which is often the case). So we assume it does not need -- any parsing environment. ----- >>> parseValue MSUnspecified "{PUSH int aaa}"--- Left 1:11:+-- >>> parseValue MSUnspecified "{PUSH int aaa}" & either (putStrLn . displayException) (const $ pure ())+-- 1:11: --   | -- 1 | {PUSH int aaa} --   |           ^^^^@@ -190,7 +204,7 @@ -- expecting value -- <BLANKLINE> parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue-parseValue = first ParserException ... parseNoEnv value+parseValue = first ParserException ... (parseNoEnv @()) value  -- | Like 'parseValue', but also expands macros. parseExpandValue :: MichelsonSource -> Text -> Either ParserException U.Value@@ -199,7 +213,7 @@ -- Primitive instruction ------------------ -prim :: Parser ParsedInstr+prim :: Parser le ParsedInstr prim = primInstr contract parsedOp  -- Parsed operations (primitive instructions, macros, extras, etc.)@@ -208,58 +222,68 @@ -- | Parses code block after "code" keyword of a contract. -- -- This function is part of the module API, its semantics should not change.-codeEntry :: Parser [ParsedOp]+codeEntry :: Parser le [ParsedOp] codeEntry = bracewrappedOps -bracewrappedOps :: Parser [ParsedOp]+bracewrappedOps :: Parser le [ParsedOp] bracewrappedOps = lookAhead (symbol "{") *> ops  -- |--- >>> first ParserException $ parseNoEnv parsedOp "" "{a}"--- Left 1:2:+-- >>> parseNoEnv @() parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())+-- 1:2: --   | -- 1 | {a} --   |  ^ -- unexpected 'a'+-- expecting '{', '}', macro, or primitive instruction+-- <BLANKLINE>+-- >>> :m + Morley.Michelson.Parser.Types+-- >>> parseNoEnv @LetEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())+-- ...+-- 1:2:+--   |+-- 1 | {a}+--   |  ^+-- unexpected 'a' -- expecting '{', '}', macro, morley instruction, or primitive instruction -- <BLANKLINE>-parsedOp :: Parser ParsedOp+parsedOp :: Parser le ParsedOp parsedOp = do-  lms <- asks letMacros   pos <- getSrcPos   choice-    [ flip Prim pos <$> (EXT <$> extInstr ops)-    , lmacWithPos (mkLetMac lms)+    [ withLetEnv $ flip Prim pos <$> (EXT <$> extInstr ops)+    , withLetEnv $ lmacWithPos     , flip Prim pos <$> prim     , flip Mac pos <$> macro parsedOp     , primOrMac     , flip Seq pos <$> bracewrappedOps     ]   where-    lmacWithPos :: Parser LetMacro -> Parser ParsedOp-    lmacWithPos act = do+    lmacWithPos :: Parser' LetEnv ParsedOp+    lmacWithPos = do+      act <- mkLetMac <$> asks letMacros       srcPos <- getSrcPos       flip LMac srcPos <$> act -getSrcPos :: Parser SrcPos+getSrcPos :: Parser le SrcPos getSrcPos = do   sp <- getSourcePos   let l = unPos $ sourceLine sp   let c = unPos $ sourceColumn sp   -- reindexing starting from 0-  pure $ SrcPos (unsafeMkPos $ l - 1) (unsafeMkPos $ c - 1)+  pure . unsafe $ SrcPos <$> (mkPos $ l - 1) <*> (mkPos $ c - 1) -primWithPos :: Parser ParsedInstr -> Parser ParsedOp+primWithPos :: Parser le ParsedInstr -> Parser le ParsedOp primWithPos act = do   srcPos <- getSrcPos   flip Prim srcPos <$> act -macWithPos :: Parser Macro -> Parser ParsedOp+macWithPos :: Parser le Macro -> Parser le ParsedOp macWithPos act = do   srcPos <- getSrcPos   flip Mac srcPos <$> act -ops :: Parser [ParsedOp]+ops :: Parser le [ParsedOp] ops = ops' parsedOp  -------------------------------------------------------------------------------@@ -267,7 +291,7 @@ -- These are needed for better error messages ------------------------------------------------------------------------------- -ifOrIfX :: Parser ParsedOp+ifOrIfX :: Parser le ParsedOp ifOrIfX = do   pos <- getSrcPos   symbol' "IF"@@ -278,7 +302,7 @@  -- Some of the operations and macros have the same prefixes in their names -- So this case should be handled separately-primOrMac :: Parser ParsedOp+primOrMac :: Parser le ParsedOp primOrMac = hidden    $  (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)   <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))@@ -290,12 +314,12 @@ -- Safe construction of Haskell values ------------------------------------------------------------------------------- -parserToQuasiQuoter :: TH.Lift a => Parser a -> TH.QuasiQuoter+parserToQuasiQuoter :: Parser () (TH.Q TH.Exp) -> TH.QuasiQuoter parserToQuasiQuoter parser = TH.QuasiQuoter   { TH.quoteExp = \s ->       case parseNoEnv (mSpace *> parser) "quasi-quoter" (toText s) of         Left err -> fail $ errorBundlePretty err-        Right res -> [e| res |]+        Right qexp -> qexp   , TH.quotePat = \_ -> fail "Cannot be used as pattern"   , TH.quoteType = \_ -> fail "Cannot be used as type"   , TH.quoteDec = \_ -> fail "Cannot be used as declaration"@@ -303,8 +327,8 @@  -- | Creates 'U.Ty' by its Morley representation. ----- >>> [utypeQ| (int :a | nat :b) |]--- Ty (TOr % % (Ty TInt :a) (Ty TNat :b)) :+-- >>> [utypeQ| or (int :a) (nat :b) |]+-- Ty (TOr (UnsafeAnnotation @FieldTag "") (UnsafeAnnotation @FieldTag "") (Ty TInt (UnsafeAnnotation @TypeTag "a")) (Ty TNat (UnsafeAnnotation @TypeTag "b"))) (UnsafeAnnotation @TypeTag "") -- -- >>> [utypeQ|a|] -- <BLANKLINE>@@ -316,8 +340,18 @@ -- expecting type -- ... utypeQ :: TH.QuasiQuoter-utypeQ = parserToQuasiQuoter type_+utypeQ = parserToQuasiQuoter (TH.lift <$> type_)  -- | Creates 'U.ParameterType' by its Morley representation. uparamTypeQ :: TH.QuasiQuoter-uparamTypeQ = parserToQuasiQuoter cbParameterBare+uparamTypeQ = parserToQuasiQuoter (TH.lift <$> cbParameterBare)++-- | Parses and typechecks a 'Morley.Michelson.Typed.Notes'.+--+-- >>> [notes|int :ty|]+-- NTInt (UnsafeAnnotation @TypeTag "ty")+notes :: TH.QuasiQuoter+notes =+  parserToQuasiQuoter do+    t <- type_+    pure $ withUType t TH.lift

@@ -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 Morley.Michelson.Parser.Annotations   ( note@@ -22,7 +21,7 @@ import Prelude hiding (note)  import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)-import qualified Data.Text as T+import Data.Text qualified as T import Text.Megaparsec (satisfy, takeWhileP) import Text.Megaparsec.Char (string) @@ -33,35 +32,35 @@ import Morley.Util.Default  -- | General T/V/F Annotation parser, including Special Annotations-note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)+note :: forall tag le. KnownAnnTag tag => Parser le (Annotation tag) note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote)   where     -- TODO [#48] these are special annotations and should not always be accepted-    specialVNote = unsafeMkAnnotation <$> asum (map string specialVarAnns)-    specialFNote = unsafeMkAnnotation <$> string specialFieldAnn+    specialVNote = unsafe . mkAnnotation <$> asum (map string specialVarAnns)+    specialFNote = unsafe . mkAnnotation <$> string specialFieldAnn     specialNote = specialVNote <|> specialFNote     emptyNote = pure noAnn     note' = do       a <- satisfy isValidAnnStart       b <- takeWhileP Nothing isValidAnnBodyChar-      return . unsafeMkAnnotation $ T.cons a b+      return . unsafe . mkAnnotation $ T.cons a b -noteV :: Parser VarAnn+noteV :: Parser le VarAnn noteV = note -noteDef :: KnownAnnTag tag => Parser (Annotation tag)+noteDef :: KnownAnnTag tag => Parser le (Annotation tag) noteDef = parseDef note -noteF :: Parser FieldAnn+noteF :: Parser le FieldAnn noteF = note -noteV2Def :: Parser (VarAnn, VarAnn)+noteV2Def :: Parser le (VarAnn, VarAnn) noteV2Def = permute2Def note note -notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)+notesTVF :: Parser le (TypeAnn, VarAnn, FieldAnn) notesTVF = permute3Def note note note -notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))+notesTVF2Def :: Parser le (TypeAnn, VarAnn, (FieldAnn, FieldAnn)) notesTVF2Def = permute3Def note note (permute2Def note note)  -- | Parse 0/1/2 var anns and 0/1/2 field anns.@@ -76,21 +75,21 @@ -- * "@c @d %a %b" is valid -- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together. -- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together.-notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))+notesVVFF :: Parser le ((VarAnn, VarAnn), (FieldAnn, FieldAnn)) notesVVFF = permute2Def (liftA2 (,) note noteDef) (liftA2 (,) note noteDef) -notesVF :: Parser (VarAnn, FieldAnn)+notesVF :: Parser le (VarAnn, FieldAnn) notesVF = permute2Def note note -notesTV :: Parser (TypeAnn, VarAnn)+notesTV :: Parser le (TypeAnn, VarAnn) notesTV = permute2Def note note -notesTF :: Parser (TypeAnn, FieldAnn)+notesTF :: Parser le (TypeAnn, FieldAnn) notesTF = permute2Def note note  fieldType :: Default a-          => Parser a-          -> Parser (a, TypeAnn)+          => Parser le a+          -> Parser le (a, TypeAnn) fieldType fp = runPermutation $   (,) <$> toPermutationWithDefault  def     fp       <*> toPermutationWithDefault noAnn note

@@ -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 Morley.Michelson.Parser.Common   ( viewName_@@ -14,7 +13,7 @@ import Morley.Michelson.Parser.Types import Morley.Michelson.Untyped -viewName_ :: Parser ViewName+viewName_ :: Parser le ViewName viewName_ = lexeme do   string "\""   str <- manyTill anySingle (string "\"")

@@ -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  -- |  Custom exceptions that can happen during parsing. @@ -14,7 +13,6 @@ import Data.Data (Data(..)) import Fmt (Buildable(build), pretty, (+|), (|+)) import Text.Megaparsec (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty)-import qualified Text.Show (show)  import Morley.Michelson.Untyped.View import Morley.Util.Instances ()@@ -29,8 +27,17 @@   | WrongSetArgs Natural Positive   | ExcessFieldAnnotation   | MultiRootAnnotationException+  | DeprecatedException   deriving stock (Eq, Data, Ord, Show, Generic) +{-# DEPRECATED+    WrongTagArgs+  , WrongAccessArgs+  , WrongSetArgs++  "Exceptions specific to deprecated Morley language extensions"+  #-}+ instance NFData CustomParserException  instance ShowErrorComponent CustomParserException where@@ -39,6 +46,8 @@   showErrorComponent OddNumberBytesException = "odd number bytes"   showErrorComponent ExcessFieldAnnotation = "excess field annotation"   showErrorComponent MultiRootAnnotationException = "unexpected multiple root annotations"+  showErrorComponent DeprecatedException = "deprecated syntax, use --deprecated-morley-extensions \+    \command-line argument to silence this error"   showErrorComponent (WrongTagArgs idx size) =     "TAG: too large index: " +| idx |+ " \            \exceedes union size " +| size |+ ""@@ -64,13 +73,10 @@  data ParserException =   ParserException (ParseErrorBundle Text CustomParserException)-  deriving stock (Eq)--instance Show ParserException where-  show (ParserException bundle) = errorBundlePretty bundle+  deriving stock (Eq, Show)  instance Exception ParserException where   displayException (ParserException bundle) = errorBundlePretty bundle  instance Buildable ParserException where-  build = build @String . show+  build (ParserException bundle) = build $ errorBundlePretty bundle

@@ -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 #-}+ -- | Parsing logic for extra instructions (Morley extensions)  module Morley.Michelson.Parser.Ext@@ -16,35 +18,36 @@  import Text.Megaparsec (choice, label, satisfy, try) import Text.Megaparsec.Char (alphaNumChar, string)-import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Char.Lexer qualified as L  import Morley.Michelson.Macro (ParsedOp(..), ParsedUExtInstr) import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Type-import Morley.Michelson.Parser.Types (Parser)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Parser.Types (LetEnv, Parser')+import Morley.Michelson.Untyped qualified as U -extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr-extInstr opsParser = label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp]+extInstr :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr+extInstr opsParser = do+  label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp] -stackOp :: Parser ParsedUExtInstr+stackOp :: Parser' LetEnv ParsedUExtInstr stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType -testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr+testAssertOp :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr testAssertOp opsParser =   word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser -printOp :: Parser ParsedUExtInstr+printOp :: Parser' LetEnv ParsedUExtInstr printOp = word' "PRINT" U.UPRINT <*> printComment -testAssert :: Parser [ParsedOp] -> Parser (U.TestAssert ParsedOp)+testAssert :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv (U.TestAssert ParsedOp) testAssert opsParser = do   n <- lexeme (toText <$> some alphaNumChar)   c <- printComment   o <- opsParser   return $ U.TestAssert n c o -printComment :: Parser U.PrintComment+printComment :: Parser' LetEnv U.PrintComment printComment = do   string "\""   let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"'))@@ -52,14 +55,15 @@   symbol "\""   return $ U.PrintComment c -stackRef :: Parser U.StackRef+stackRef :: Parser' LetEnv U.StackRef stackRef = do   string "%"   n <- brackets' L.decimal   return $ U.StackRef n -stackType :: Parser U.StackTypePattern-stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)+stackType :: Parser' LetEnv U.StackTypePattern+stackType = do+  symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)   where     emptyStk = try $ symbol "]" $> U.StkEmpty     stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest@@ -68,5 +72,5 @@       s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk       return $ U.StkCons t s -tyVar :: Parser U.TyVar+tyVar :: Parser' LetEnv U.TyVar tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID)

@@ -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-redundant-constraints #-}+ module Morley.Michelson.Parser.Helpers   ( mkParser   , sepEndBy1@@ -10,16 +12,18 @@   , sepBy2   , parseDef   , positive+  , count   ) where  import Data.Default (Default(..))-import qualified Data.List.NonEmpty as NE-import qualified Text.Megaparsec as P+import Data.List.NonEmpty qualified as NE+import Text.Megaparsec qualified as P import Text.Megaparsec.Char.Lexer (decimal)  import Morley.Michelson.Parser.Lexer (word') import Morley.Michelson.Parser.Types (Parser) import Morley.Util.Positive+import Morley.Util.SizedList.Types  -- | Version of 'P.sepEndBy1' returning a 'NonEmpty' list sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a)@@ -42,16 +46,23 @@   return $ e :| es  -- | Make a parser from a string-mkParser :: (a -> Text) -> a -> Parser a-mkParser f a = P.try $ word' (f a) a+mkParser :: (a -> Text) -> a -> Parser le a+mkParser f a = word' (f a) a  -- | Apply given parser and return default value if it fails.-parseDef :: Default a => Parser a -> Parser a+parseDef :: Default a => Parser le a -> Parser le a parseDef a = P.try a <|> pure def  -- | Parse a positive number.-positive :: Parser Positive+positive :: Parser le Positive positive = do   n :: Integer <- decimal   mkPositive n     & either (fail . toString) pure++-- | Parse expression @n@ times, where @n@ is a type-level natural.+-- Essentially, a type-safe version of 'P.count', but requires+-- the count to be known on the type level.+count :: (SingIPeano n, Applicative m) => m a -> m (SizedList n a)+count = sequenceA . pure+{-# INLINE count #-}

@@ -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 -Wno-redundant-constraints #-}+ -- | Parsing of Michelson instructions.  module Morley.Michelson.Parser.Instr@@ -16,12 +18,13 @@   , dupOp   , carOp   , cdrOp+  , viewOp   ) where  import Prelude hiding (EQ, GT, LT, many, note, some, try) -import Text.Megaparsec (choice, label, lookAhead, notFollowedBy, satisfy, sepEndBy, try)-import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec (choice, label, notFollowedBy, try)+import Text.Megaparsec.Char.Lexer qualified as L  import Morley.Michelson.Let (LetValue(..)) import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..))@@ -29,12 +32,12 @@ import Morley.Michelson.Parser.Common import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Type-import Morley.Michelson.Parser.Types (Parser, letValues)+import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', letValues, withLetEnv) import Morley.Michelson.Parser.Value import Morley.Michelson.Untyped  -- | Parser for primitive Michelson instruction (no macros and extensions).-primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr+primInstr :: Parser' le (Contract' ParsedOp) -> Parser' le ParsedOp -> Parser le ParsedInstr primInstr contractParser opParser = label "primitive instruction" $ choice   [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp   , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp@@ -42,7 +45,7 @@   , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opParser, loopOp opParser   , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp   , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp-  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp+  , subMutezOp, mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp   , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, viewOp, selfOp, contractOp   , transferTokensOp, setDelegateOp   , createContractOp contractParser, implicitAccountOp, nowOp, amountOp@@ -52,403 +55,424 @@   , unpairOp   , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp   , openChestOp+  , saplingEmptyStateOp, saplingVerifyUpdateOp   ]  -- | Parse a sequence of instructions.-ops' :: Parser ParsedOp -> Parser [ParsedOp]-ops' opParser = (braces $ sepEndBy opParser (optional semicolon)) <|> (pure <$> opParser)+ops' :: Parser' le ParsedOp -> Parser le [ParsedOp]+ops' opParser = (braces $ parseSeq) <|> (pure <$> opParser)+  where+    parseSeq =+      do{ op <- opParser+        ; let separator = case op of+                Seq _ _ -> void (optional semicolon)+                _       -> semicolon+        ; do{ _ <- separator+            ; ops <- parseSeq+            ; return (op:ops)+            }+           <|> return [op]+      }+      <|> return [] + -- Control Structures -failWithOp :: Parser ParsedInstr+failWithOp :: Parser le ParsedInstr failWithOp = word' "FAILWITH" FAILWITH -loopOp :: Parser ParsedOp -> Parser ParsedInstr+loopOp :: Parser' le ParsedOp -> Parser le ParsedInstr loopOp opParser = word' "LOOP" LOOP <*> ops' opParser -loopLOp :: Parser ParsedOp -> Parser ParsedInstr+loopLOp :: Parser' le ParsedOp -> Parser le ParsedInstr loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser -execOp :: Parser ParsedInstr+execOp :: Parser le ParsedInstr execOp = word' "EXEC" EXEC <*> noteDef -applyOp :: Parser ParsedInstr+applyOp :: Parser le ParsedInstr applyOp = word' "APPLY" APPLY <*> noteDef  -- Parses both `DIP` and `DIP n`.-dipOp :: Parser ParsedOp -> Parser ParsedInstr+dipOp :: Parser' le ParsedOp -> Parser le ParsedInstr dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser  -- Helper for instructions which have optional numeric non-negative parameter.-parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser instr+parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser le instr parseWithOptionalParameter instrName constructorWithParam constructorNoParam =-  symbol' instrName *>+  symbol1' instrName *>   (try (constructorWithParam <$> lexeme L.decimal) <|> pure constructorNoParam)  -- Stack Operations  -- Parses both `DROP` and `DROP n`.-dropOp :: Parser ParsedInstr+dropOp :: Parser le ParsedInstr dropOp = parseWithOptionalParameter "DROP" DROPN DROP -dupOp :: Parser ParsedInstr+dupOp :: Parser le ParsedInstr dupOp = do-  symbol' "DUP"+  symbol1' "DUP"   varAnn <- noteDef   optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn) -swapOp :: Parser ParsedInstr+swapOp :: Parser le ParsedInstr swapOp = word' "SWAP" SWAP -digOp :: Parser ParsedInstr+digOp :: Parser le ParsedInstr digOp = word' "DIG" DIG <*> lexeme L.decimal -dugOp :: Parser ParsedInstr+dugOp :: Parser le ParsedInstr dugOp = word' "DUG" DUG <*> lexeme L.decimal -pushOp :: Parser ParsedOp -> Parser ParsedInstr+pushOp :: forall le. Parser' le ParsedOp -> Parser le ParsedInstr pushOp opParser = do-  symbol' "PUSH"+  symbol1' "PUSH"   v <- noteDef-  (try $ pushLet v) <|> (push' v)+  (try $ withLetEnv $ pushLet v) <|> (push' v)   where+    pushLet :: VarAnn -> Parser' LetEnv ParsedInstr     pushLet v = do       lvs <- asks letValues       lv <- mkLetVal lvs       return $ PUSH v (lvSig lv) (lvVal lv)+    push' :: VarAnn -> Parser le ParsedInstr     push' v = PUSH v <$> type_ <*> value' opParser -unitOp :: Parser ParsedInstr-unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ UNIT t v+unitOp :: Parser le ParsedInstr+unitOp = do symbol1' "UNIT"; (t, v) <- notesTV; return $ UNIT t v -lambdaOp :: Parser ParsedOp -> Parser ParsedInstr+lambdaOp :: Parser' le ParsedOp -> Parser le ParsedInstr lambdaOp opParser =   word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser -neverOp :: Parser ParsedInstr+neverOp :: Parser le ParsedInstr neverOp = word' "NEVER" NEVER -- Generic comparison -cmpOp :: Parser ParsedInstr+cmpOp :: Parser le ParsedInstr cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp -eqOp :: Parser ParsedInstr+eqOp :: Parser le ParsedInstr eqOp = word' "EQ" EQ <*> noteDef -neqOp :: Parser ParsedInstr+neqOp :: Parser le ParsedInstr neqOp = word' "NEQ" NEQ <*> noteDef -ltOp :: Parser ParsedInstr+ltOp :: Parser le ParsedInstr ltOp = word' "LT" LT <*> noteDef -gtOp :: Parser ParsedInstr+gtOp :: Parser le ParsedInstr gtOp = word' "GT" GT <*> noteDef -leOp :: Parser ParsedInstr+leOp :: Parser le ParsedInstr leOp = word' "LE" LE <*> noteDef -geOp :: Parser ParsedInstr+geOp :: Parser le ParsedInstr geOp = word' "GE" GE <*> noteDef  -- ad-hoc comparison -compareOp :: Parser ParsedInstr+compareOp :: Parser le ParsedInstr compareOp = word' "COMPARE" COMPARE <*> noteDef  -- Operations on booleans -orOp :: Parser ParsedInstr+orOp :: Parser le ParsedInstr orOp = word' "OR"  OR <*> noteDef -andOp :: Parser ParsedInstr+andOp :: Parser le ParsedInstr andOp = word' "AND" AND <*> noteDef -xorOp :: Parser ParsedInstr+xorOp :: Parser le ParsedInstr xorOp = word' "XOR" XOR <*> noteDef -notOp :: Parser ParsedInstr+notOp :: Parser le ParsedInstr notOp = word' "NOT" NOT <*> noteDef  -- Operations on integers and natural numbers -addOp :: Parser ParsedInstr+addOp :: Parser le ParsedInstr addOp = word' "ADD" ADD <*> noteDef -subOp :: Parser ParsedInstr+saplingEmptyStateOp :: Parser le ParsedInstr+saplingEmptyStateOp = word' "SAPLING_EMPTY_STATE" SAPLING_EMPTY_STATE <*> noteDef <*> lexeme L.decimal++saplingVerifyUpdateOp :: Parser le ParsedInstr+saplingVerifyUpdateOp = word' "SAPLING_VERIFY_UPDATE" SAPLING_VERIFY_UPDATE <*> noteDef++subOp :: Parser le ParsedInstr subOp = word' "SUB" SUB <*> noteDef -mulOp :: Parser ParsedInstr+subMutezOp :: Parser le ParsedInstr+subMutezOp = word' "SUB_MUTEZ" SUB_MUTEZ <*> noteDef++mulOp :: Parser le ParsedInstr mulOp = word' "MUL" MUL <*> noteDef -edivOp :: Parser ParsedInstr+edivOp :: Parser le ParsedInstr edivOp = word' "EDIV" EDIV <*> noteDef -absOp :: Parser ParsedInstr+absOp :: Parser le ParsedInstr absOp = word' "ABS" ABS <*> noteDef -negOp :: Parser ParsedInstr+negOp :: Parser le ParsedInstr negOp = word' "NEG" NEG <*> noteDef  -- Bitwise logical operators -lslOp :: Parser ParsedInstr+lslOp :: Parser le ParsedInstr lslOp = word' "LSL" LSL <*> noteDef -lsrOp :: Parser ParsedInstr+lsrOp :: Parser le ParsedInstr lsrOp = word' "LSR" LSR <*> noteDef  -- Operations on string's -concatOp :: Parser ParsedInstr+concatOp :: Parser le ParsedInstr concatOp = word' "CONCAT" CONCAT <*> noteDef -sliceOp :: Parser ParsedInstr+sliceOp :: Parser le ParsedInstr sliceOp = word' "SLICE" SLICE <*> noteDef  -- Operations on pairs-pairOp :: Parser ParsedInstr+pairOp :: Parser le ParsedInstr pairOp = do-  symbol' "PAIR"+  symbol1' "PAIR"   (t, v, (p, q)) <- notesTVF2Def    -- Make sure this is a `PAIR` instruction,   -- and not a `PAIR n` instruction.-  notFollowedBy (lexeme L.decimal :: Parser Word)+  notFollowedBy (lexeme L.decimal :: Parser le Word)    return $ PAIR t v p q -unpairOp :: Parser ParsedInstr+unpairOp :: Parser le ParsedInstr unpairOp = do-  symbol' "UNPAIR"+  symbol1' "UNPAIR"   ((vn1, vn2), (fn1, fn2)) <- notesVVFF    -- Make sure this is an `UNPAIR` instruction,   -- and not an `UNPAIR n` instruction.-  notFollowedBy (lexeme L.decimal :: Parser Word)+  notFollowedBy (lexeme L.decimal :: Parser le Word)    return $ UNPAIR vn1 vn2 fn1 fn2 -pairNOp :: Parser ParsedInstr+pairNOp :: Parser le ParsedInstr pairNOp = do-  symbol' "PAIR"+  symbol1' "PAIR"   PAIRN     <$> noteDef     <*> lexeme L.decimal -unpairNOp :: Parser ParsedInstr+unpairNOp :: Parser le ParsedInstr unpairNOp =   word' "UNPAIR" UNPAIRN <*> lexeme L.decimal -carOp :: Parser ParsedInstr-carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ CAR v f+carOp :: Parser le ParsedInstr+carOp = do symbol1' "CAR"; (v, f) <- notesVF; return $ CAR v f -cdrOp :: Parser ParsedInstr-cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ CDR v f+cdrOp :: Parser le ParsedInstr+cdrOp = do symbol1' "CDR"; (v, f) <- notesVF; return $ CDR v f  -- Operations on collections (sets, maps, lists) -emptySetOp :: Parser ParsedInstr-emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;+emptySetOp :: Parser le ParsedInstr+emptySetOp = do symbol1' "EMPTY_SET"; (t, v) <- notesTV;                 EMPTY_SET t v <$> type_ -emptyMapOp :: Parser ParsedInstr-emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- type_;+emptyMapOp :: Parser le ParsedInstr+emptyMapOp = do symbol1' "EMPTY_MAP"; (t, v) <- notesTV; a <- type_;                 EMPTY_MAP t v a <$> type_ -emptyBigMapOp :: Parser ParsedInstr-emptyBigMapOp = do symbol' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_;+emptyBigMapOp :: Parser le ParsedInstr+emptyBigMapOp = do symbol1' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_;                    EMPTY_BIG_MAP t v a <$> type_ -memOp :: Parser ParsedInstr+memOp :: Parser le ParsedInstr memOp = word' "MEM" MEM <*> noteDef -updateOp :: Parser ParsedInstr+updateOp :: Parser le ParsedInstr updateOp = do-  symbol' "UPDATE"+  symbol1' "UPDATE"   varAnn <- noteDef   ix <- optional (lexeme L.decimal)   pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix -getAndUpdateOp :: Parser ParsedInstr+getAndUpdateOp :: Parser le ParsedInstr getAndUpdateOp = word' "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef -iterOp :: Parser ParsedOp -> Parser ParsedInstr+iterOp :: Parser' le ParsedOp -> Parser le ParsedInstr iterOp opParser = word' "ITER" ITER <*> ops' opParser -sizeOp :: Parser ParsedInstr+sizeOp :: Parser le ParsedInstr sizeOp = word' "SIZE" SIZE <*> noteDef -mapOp :: Parser ParsedOp -> Parser ParsedInstr+mapOp :: Parser' le ParsedOp -> Parser le ParsedInstr mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser -getOp :: Parser ParsedInstr+getOp :: Parser le ParsedInstr getOp = do-  symbol' "GET"+  symbol1' "GET"   varAnn <- noteDef   ix <- optional (lexeme L.decimal)   pure $ maybe (GET varAnn) (GETN varAnn) ix -nilOp :: Parser ParsedInstr-nilOp = do symbol' "NIL"; (t, v) <- notesTV; NIL t v <$> type_+nilOp :: Parser le ParsedInstr+nilOp = do symbol1' "NIL"; (t, v) <- notesTV; NIL t v <$> type_ -consOp :: Parser ParsedInstr-consOp = do-  try . lexeme $ do-    void $ string' "CONS"-    notFollowedBy (string' "T")-  CONS <$> noteDef+consOp :: Parser le ParsedInstr+consOp = word' "CONS" CONS <*> noteDef -ifConsOp :: Parser ParsedOp -> Parser ParsedInstr+ifConsOp :: Parser' le ParsedOp -> Parser le ParsedInstr ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser  -- Operations on options -someOp :: Parser ParsedInstr-someOp = do symbol' "SOME"; (t, v) <- notesTV; return $ SOME t v+someOp :: Parser le ParsedInstr+someOp = do symbol1' "SOME"; (t, v) <- notesTV; return $ SOME t v -noneOp :: Parser ParsedInstr-noneOp = do symbol' "NONE"; (t, v) <- notesTV; NONE t v <$> type_+noneOp :: Parser le ParsedInstr+noneOp = do symbol1' "NONE"; (t, v) <- notesTV; NONE t v <$> type_ -ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr+ifNoneOp :: Parser' le ParsedOp -> Parser le ParsedInstr ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser  -- Operations on unions -leftOp :: Parser ParsedInstr-leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;+leftOp :: Parser le ParsedInstr+leftOp = do symbol1' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;                LEFT t v f f' <$> type_ -rightOp :: Parser ParsedInstr-rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;+rightOp :: Parser le ParsedInstr+rightOp = do symbol1' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;                RIGHT t v f f' <$> type_ -ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr+ifLeftOp :: Parser' le ParsedOp -> Parser le ParsedInstr ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser  -- Operations on contracts -createContractOp :: Parser (Contract' ParsedOp) -> Parser ParsedInstr+createContractOp :: Parser le (Contract' ParsedOp) -> Parser le ParsedInstr createContractOp contractParser =   word' "CREATE_CONTRACT" CREATE_CONTRACT     <*> noteDef <*> noteDef <*> braces contractParser -transferTokensOp :: Parser ParsedInstr+transferTokensOp :: Parser le ParsedInstr transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef -setDelegateOp :: Parser ParsedInstr+setDelegateOp :: Parser le ParsedInstr setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef -balanceOp :: Parser ParsedInstr+balanceOp :: Parser le ParsedInstr balanceOp = word' "BALANCE" BALANCE <*> noteDef -contractOp :: Parser ParsedInstr+contractOp :: Parser le ParsedInstr contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_ -sourceOp :: Parser ParsedInstr+sourceOp :: Parser le ParsedInstr sourceOp = word' "SOURCE" SOURCE <*> noteDef -senderOp :: Parser ParsedInstr+senderOp :: Parser le ParsedInstr senderOp = word' "SENDER" SENDER <*> noteDef -amountOp :: Parser ParsedInstr+amountOp :: Parser le ParsedInstr amountOp = word' "AMOUNT" AMOUNT <*> noteDef -votingPowerOp :: Parser ParsedInstr+votingPowerOp :: Parser le ParsedInstr votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef -totalVotingPowerOp :: Parser ParsedInstr+totalVotingPowerOp :: Parser le ParsedInstr totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef -implicitAccountOp :: Parser ParsedInstr+implicitAccountOp :: Parser le ParsedInstr implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef -viewOp :: Parser ParsedInstr+viewOp :: Parser le ParsedInstr viewOp =   -- @VIEW_@ A1 macro should not be parsed by this-  -- TODO [#557] this 'lookAhead' and 'try' should become unnecessary-  try (word' "VIEW" VIEW <* lookAhead (satisfy (/= '_'))) <*> noteDef <*> viewName_ <*> type_+  word' "VIEW" VIEW <*> noteDef <*> viewName_ <*> type_ -selfOp :: Parser ParsedInstr+selfOp :: Parser le ParsedInstr selfOp = word' "SELF" SELF <*> noteDef <*> noteDef -addressOp :: Parser ParsedInstr+addressOp :: Parser le ParsedInstr addressOp = word' "ADDRESS" ADDRESS <*> noteDef -selfAddressOp :: Parser ParsedInstr+selfAddressOp :: Parser le ParsedInstr selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef  -- Special Operations -nowOp :: Parser ParsedInstr+nowOp :: Parser le ParsedInstr nowOp = word' "NOW" NOW <*> noteDef -levelOp :: Parser ParsedInstr+levelOp :: Parser le ParsedInstr levelOp = word' "LEVEL" LEVEL <*> noteDef -chainIdOp :: Parser ParsedInstr+chainIdOp :: Parser le ParsedInstr chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef  -- Operations on bytes -packOp :: Parser ParsedInstr+packOp :: Parser le ParsedInstr packOp = word' "PACK" PACK <*> noteDef -unpackOp :: Parser ParsedInstr-unpackOp = do symbol' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_+unpackOp :: Parser le ParsedInstr+unpackOp = do symbol1' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_  -- Cryptographic Primitives -checkSigOp :: Parser ParsedInstr+checkSigOp :: Parser le ParsedInstr checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef -blake2BOp :: Parser ParsedInstr+blake2BOp :: Parser le ParsedInstr blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef -sha256Op :: Parser ParsedInstr+sha256Op :: Parser le ParsedInstr sha256Op = word' "SHA256" SHA256 <*> noteDef -sha512Op :: Parser ParsedInstr+sha512Op :: Parser le ParsedInstr sha512Op = word' "SHA512" SHA512 <*> noteDef -sha3Op :: Parser ParsedInstr+sha3Op :: Parser le ParsedInstr sha3Op = word' "SHA3" SHA3 <*> noteDef -keccakOp :: Parser ParsedInstr+keccakOp :: Parser le ParsedInstr keccakOp = word' "KECCAK" KECCAK <*> noteDef -hashKeyOp :: Parser ParsedInstr+hashKeyOp :: Parser le ParsedInstr hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef -pairingCheckOp :: Parser ParsedInstr+pairingCheckOp :: Parser le ParsedInstr pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef  -- Type operations -castOp :: Parser ParsedInstr+castOp :: Parser le ParsedInstr castOp = word' "CAST" CAST <*> noteDef <*> type_ -renameOp :: Parser ParsedInstr+renameOp :: Parser le ParsedInstr renameOp = word' "RENAME" RENAME <*> noteDef -isNatOp :: Parser ParsedInstr+isNatOp :: Parser le ParsedInstr isNatOp = word' "ISNAT" ISNAT <*> noteDef -intOp :: Parser ParsedInstr+intOp :: Parser le ParsedInstr intOp = word' "INT" INT <*> noteDef  -- Ticket Operations -ticketOp :: Parser ParsedInstr+ticketOp :: Parser le ParsedInstr ticketOp = word' "TICKET" TICKET <*> noteDef -readTicketOp :: Parser ParsedInstr+readTicketOp :: Parser le ParsedInstr readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef -splitTicketOp :: Parser ParsedInstr+splitTicketOp :: Parser le ParsedInstr splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef -joinTicketsOp :: Parser ParsedInstr+joinTicketsOp :: Parser le ParsedInstr joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef -openChestOp :: Parser ParsedInstr+openChestOp :: Parser le ParsedInstr openChestOp = word' "OPEN_CHEST" OPEN_CHEST <*> noteDef

@@ -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 #-}+ -- | Parsing of let blocks  module Morley.Michelson.Parser.Let@@ -14,9 +16,10 @@  import Prelude hiding (try) -import qualified Data.Char as Char-import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.Char qualified as Char+import Data.Map qualified as Map+import Data.Set qualified as Set+import Data.Type.Equality ((:~:)(Refl))  import Text.Megaparsec (choice, satisfy, try) import Text.Megaparsec.Char (lowerChar, upperChar)@@ -28,7 +31,7 @@ import Morley.Michelson.Parser.Instr import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Type-import Morley.Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)+import Morley.Michelson.Parser.Types (LetEnv(..), Parser, Parser', assertLetEnv, noLetEnv) import Morley.Michelson.Parser.Value import Morley.Michelson.Untyped (StackFn(..), Ty(..), mkAnnotation, noAnn) @@ -36,17 +39,18 @@ data Let = LetM LetMacro | LetV LetValue | LetT LetType  -- | let block parser-letBlock :: Parser ParsedOp -> Parser LetEnv+letBlock :: forall le. Parser' le ParsedOp -> Parser le le letBlock opParser = do   symbol "let"   symbol "{"+  Refl <- assertLetEnv   ls <- local (const noLetEnv) (letInner opParser)   symbol "}"   semicolon   return ls  -- | Incrementally build the let environment-letInner :: Parser ParsedOp -> Parser LetEnv+letInner :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetEnv letInner opParser = do   env <- ask   l <- lets opParser@@ -60,7 +64,7 @@   LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts   LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts) -lets :: Parser ParsedOp -> Parser Let+lets :: Parser' LetEnv ParsedOp -> Parser' LetEnv Let lets opParser = choice   [ (LetM <$> letMacro opParser)   , (LetV <$> letValue opParser)@@ -68,16 +72,14 @@   ]  -- | Build a let name parser from a leading character parser-letName :: Parser Char -> Parser Text+letName :: Parser' LetEnv Char -> Parser' LetEnv Text letName p = lexeme $ do   v <- p-  -- FIXME (#557): It is possible to define a let name such as "add3", but then-  -- the parser doesn't recognize when it's used as an instruction.   let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')   vs <- many (satisfy validChar)   return $ toText (v:vs) -letMacro :: Parser ParsedOp -> Parser LetMacro+letMacro :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetMacro letMacro opParser = lexeme $ do   n <- try $ do     n <- letName lowerChar@@ -88,7 +90,7 @@   o <- ops' opParser   return $ LetMacro n s o -letType :: Parser LetType+letType :: Parser' LetEnv LetType letType = lexeme $ do   n <- try $ do     symbol "type"@@ -102,7 +104,7 @@       Left err -> fail $ toString err     else return $ LetType n t -letValue :: Parser ParsedOp -> Parser LetValue+letValue :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetValue letValue opParser = lexeme $ do   n <- try $ do     n <- letName upperChar@@ -113,10 +115,10 @@   v <- value' opParser   return $ LetValue n t v -mkLetMac :: Map Text LetMacro -> Parser LetMacro+mkLetMac :: Map Text LetMacro -> Parser' LetEnv LetMacro mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms) -stackFn :: Parser StackFn+stackFn :: Parser' LetEnv StackFn stackFn = do   vs <- (optional (symbol "forall" >> some varID <* symbol "."))   a <- stackType

@@ -1,12 +1,17 @@--- 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-redundant-constraints #-}+ module Morley.Michelson.Parser.Lexer   ( lexeme   , mSpace+  , spaces   , symbol   , symbol'+  , symbol1+  , symbol1'   , word   , word'   , string'@@ -19,63 +24,81 @@   , varID   ) where +import Prelude hiding (try)+ import Data.Char (isDigit, isLower, toLower)-import qualified Data.Text as T-import Text.Megaparsec (MonadParsec, Tokens, between, satisfy)+import Data.Text qualified as T+import Text.Megaparsec (Tokens, between, choice, eof, hidden, lookAhead, satisfy, try) import Text.Megaparsec.Char (lowerChar, space, space1, string)-import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Char.Lexer qualified as L -import Morley.Michelson.Parser.Types (Parser)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Parser.Types (Parser, Parser')+import Morley.Michelson.Untyped qualified as U  -- Lexing-lexeme :: Parser a -> Parser a-lexeme = L.lexeme mSpace+lexeme :: Parser le a -> Parser le a+lexeme = L.lexeme spaces -mSpace :: Parser ()+mSpace :: Parser le () mSpace = L.space space1-  (L.skipLineComment "#")-  (L.skipBlockComment "/*" "*/" >> space >> void (optional semicolon))+  (L.skipLineComment "#" >> optionalSemicolon)+  (L.skipBlockComment "/*" "*/" >> optionalSemicolon)+  where+    optionalSemicolon = space >> void (optional semicolon) +spaces :: Parser le ()+spaces =+  (mandatorySpaceOrComment >> mSpace)+  <|> hasFollowingDelimiter ["}", "{", "]", ")", "|", ",", ";", ":", "."]+  <|> eof+  where+    mandatorySpaceOrComment = hidden (space1 <|> L.skipBlockComment "/*" "*/")+    hasFollowingDelimiter = hidden . choice . map (void . lookAhead . string) -symbol :: Tokens Text -> Parser ()+symbol :: Tokens Text -> Parser le () symbol = void . L.symbol mSpace -symbol' :: Text -> Parser ()+symbol' :: Text -> Parser le () symbol' str = symbol str <|> symbol (T.map toLower str) -word :: Tokens Text -> a -> Parser a-word str val = symbol str $> val+symbol1 :: Tokens Text -> Parser le ()+symbol1 = try . void . L.symbol spaces -word' :: Tokens Text -> a -> Parser a-word' str val = symbol' str $> val+symbol1' :: Text -> Parser le ()+symbol1' str = symbol1 str <|> symbol1 (T.map toLower str) -string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text+word :: Tokens Text -> a -> Parser le a+word str val = symbol1 str $> val++word' :: Tokens Text -> a -> Parser le a+word' str val = symbol1' str $> val++string' :: Text -> Parser le Text string' str = string str <|> string (T.map toLower str) -parens :: Parser a -> Parser a+parens :: Parser le a -> Parser le a parens = between (symbol "(") (symbol ")") -braces :: Parser a -> Parser a+braces :: Parser le a -> Parser le a braces = between (symbol "{") (symbol "}") -brackets :: Parser a -> Parser a+brackets :: Parser le a -> Parser le a brackets = between (symbol "[") (symbol "]") -brackets' :: Parser a -> Parser a+brackets' :: Parser le a -> Parser le a brackets' = between (string "[") (string "]") -semicolon :: Parser ()+semicolon :: Parser le () semicolon = symbol ";" -comma :: Parser ()+comma :: Parser le () comma = symbol "," -varID :: Parser U.Var+varID :: Parser le U.Var varID = lexeme $ do   v <- lowerChar   vs <- many lowerAlphaNumChar   return $ U.Var (toText (v:vs))   where-    lowerAlphaNumChar :: Parser Char+    lowerAlphaNumChar :: Parser' le Char     lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x)

@@ -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 #-}+ -- | Parsing of built-in Michelson macros.  module Morley.Michelson.Parser.Macro@@ -20,126 +22,126 @@  import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try) import Text.Megaparsec.Char.Lexer (decimal)-import qualified Unsafe (fromIntegral)+import Unsafe qualified (fromIntegral)  import Morley.Michelson.Macro   (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))-import qualified Morley.Michelson.Macro as Macro+import Morley.Michelson.Macro qualified as Macro import Morley.Michelson.Parser.Annotations import Morley.Michelson.Parser.Error import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Instr import Morley.Michelson.Parser.Lexer import Morley.Michelson.Parser.Type-import Morley.Michelson.Parser.Types (Parser)+import Morley.Michelson.Parser.Types (Parser, Parser', assertLetEnv) import Morley.Michelson.Untyped (T(..), Ty(..), noAnn) import Morley.Util.Positive -macro :: Parser ParsedOp -> Parser Macro+macro :: Parser' le ParsedOp -> Parser le Macro macro opParser = label "macro"-   $  word' "CASE" CASE <*> someNE ops-  <|> symbol' "TAG" *> tagMac-  <|> symbol' "ACCESS" *> accessMac-  <|> symbol' "SET " *> setMac-  <|> word' "CONSTRUCT" CONSTRUCT <*> someNE ops-  <|> word' "VIEW_" VIEW_ <*> ops-  <|> word' "VOID" VOID <*> ops-  <|> word' "CMP" CMP <*> cmpOp <*> noteDef+   $ setCadrMac+  <|> (word' "CASE" CASE <* assertLetEnv) <*> someNE ops+  <|> (symbol1' "TAG" <* assertLetEnv) *> tagMac+  <|> (symbol1' "ACCESS" <* assertLetEnv) *> accessMac+  <|> (symbol1' "SET" <* assertLetEnv) *> setMac+  <|> (word' "CONSTRUCT" CONSTRUCT <* assertLetEnv) <*> someNE ops+  <|> (word' "VIEW_" VIEW_ <* assertLetEnv) <*> ops+  <|> (word' "VOID" VOID <* assertLetEnv) <*> ops+  <|> (string' "CMP" >> return CMP <*> cmpOp <*> noteDef)   <|> word' "IF_SOME" IF_SOME <*> ops <*> ops   <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops   <|> word' "FAIL" FAIL-  <|> word' "ASSERT_CMP" ASSERT_CMP <*> cmpOp+  <|> (string' "ASSERT_CMP" >> return ASSERT_CMP <*> cmpOp)   <|> word' "ASSERT_NONE" ASSERT_NONE   <|> word' "ASSERT_SOME" ASSERT_SOME   <|> word' "ASSERT_LEFT" ASSERT_LEFT   <|> word' "ASSERT_RIGHT" ASSERT_RIGHT-  <|> word' "ASSERT_" ASSERTX <*> cmpOp+  <|> (string' "ASSERT_" >> return ASSERTX <*> cmpOp)   <|> word' "ASSERT" ASSERT-  <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops+  <|> do string' "DI"; n <- num "I"; symbol1' "P"; DIIP (n + 1) <$> ops   <|> unpairMac-  <|> setCadrMac   where    ops = ops' opParser    num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str) -duupMac :: Parser Macro-duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef+duupMac :: Parser le Macro+duupMac = do string' "DU"; n <- num "U"; symbol1' "P"; DUUP (n + 1) <$> noteDef   where     num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str) -pairMacInner :: Parser PairStruct+pairMacInner :: Parser le PairStruct pairMacInner = do   string' "P"   l <- (string' "A" $> F noAnn) <|> pairMacInner   r <- (string' "I" $> F noAnn) <|> pairMacInner   return $ P l r -pairMac :: Parser Macro+pairMac :: Parser le Macro pairMac = do   a <- pairMacInner-  symbol' "R"+  symbol1' "R"   (tn, vn, fns) <- permute3Def noteDef note (some note)   let ps = Macro.mapPairLeaves fns a   return $ PAPAIR ps tn vn -unpairMacInner :: Parser UnpairStruct+unpairMacInner :: Parser le UnpairStruct unpairMacInner = do   string' "P"   l <- (string' "A" $> UF) <|> unpairMacInner   r <- (string' "I" $> UF) <|> unpairMacInner   return $ UP l r -unpairMac :: Parser Macro+unpairMac :: Parser le Macro unpairMac = do   string' "UN"   a <- unpairMacInner-  symbol' "R"+  symbol1' "R"   skipMany $ (void noteF) <|> (void noteV)   return $ UNPAPAIR a -cadrMac :: Parser Macro+cadrMac :: Parser le Macro cadrMac = lexeme $ do   string' "C"   a <- some $ try $ cadrInner <* notFollowedBy (string' "R")   b <- cadrInner-  symbol' "R"+  symbol1' "R"   (vn, fn) <- notesVF   return $ CADR (a ++ pure b) vn fn -cadrInner :: Parser CadrStruct+cadrInner :: Parser le CadrStruct cadrInner = (string' "A" $> A) <|> (string' "D" $> D) -carnMac :: Parser Macro-carnMac = symbol' "CAR" *> (CARN <$> noteDef <*> lexeme decimal)+carnMac :: Parser le Macro+carnMac = symbol1' "CAR" *> (CARN <$> noteDef <*> lexeme decimal) -cdrnMac :: Parser Macro-cdrnMac = symbol' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)+cdrnMac :: Parser le Macro+cdrnMac = symbol1' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)  {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}-setCadrMac :: Parser Macro+setCadrMac :: Parser le Macro setCadrMac = do   string' "SET_C"   a <- some cadrInner-  symbol' "R"+  symbol1' "R"   (v, f) <- notesVF   return $ SET_CADR a v f -mapCadrMac :: Parser ParsedOp -> Parser Macro+mapCadrMac :: Parser le ParsedOp -> Parser le Macro mapCadrMac opParser = do   string' "MAP_C"   a <- some cadrInner-  symbol' "R"+  symbol1' "R"   (v, f) <- notesVF   MAP_CADR a v f <$> ops' opParser -ifCmpMac :: Parser ParsedOp -> Parser Macro-ifCmpMac opParser =-  word' "IFCMP" IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser+ifCmpMac :: Parser le ParsedOp -> Parser le Macro+ifCmpMac opParser = string' "IFCMP" >> return+  IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser -tagMac :: Parser Macro+tagMac :: Parser le Macro tagMac = do   idx <- decimal-  mSpace+  spaces   ty <- type_   let utys = unrollUnion ty []   when (Unsafe.fromIntegral @Natural @Int idx >= length utys) $@@ -151,19 +153,19 @@       Ty (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r       _ -> (ty :|) -accessMac :: Parser Macro+accessMac :: Parser le Macro accessMac = do   idx <- decimal-  mSpace+  spaces   size <- positive   when (idx >= unPositive size) $     customFailure $ WrongAccessArgs idx size   return $ ACCESS idx size -setMac :: Parser Macro+setMac :: Parser le Macro setMac = do   idx <- decimal-  mSpace+  spaces   size <- positive   when (idx >= unPositive size) $     customFailure $ WrongSetArgs idx size

@@ -1,7 +1,12 @@--- 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 #-}++-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ -- | Parsing of Michelson types.  module Morley.Michelson.Parser.Type@@ -12,16 +17,18 @@ import Prelude hiding (note, some, try)  import Data.Default (Default, def)-import qualified Data.Map as Map+import Data.Map qualified as Map+import Data.Type.Equality ((:~:)(Refl)) import Fmt (pretty) import Text.Megaparsec (choice, customFailure, label, sepBy)+import Text.Megaparsec.Char.Lexer qualified as L  import Morley.Michelson.Let (LetType(..)) import Morley.Michelson.Parser.Annotations import Morley.Michelson.Parser.Error import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Lexer-import Morley.Michelson.Parser.Types (Parser, letTypes)+import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', assertLetEnv, isLetEnv, letTypes) import Morley.Michelson.Untyped import Morley.Util.Generic @@ -29,17 +36,17 @@ -- -- Note that this includes parenthesized ones for efficiency, see 't_operator'. -- That is to say, @int@, @(int)@, @((int))@, etc will match with this parser and produce @TInt@.-type_ :: Parser Ty+type_ :: Parser le Ty type_ = snd <$> typeInner (pure noAnn) -field :: Parser (FieldAnn, Ty)+field :: Parser le (FieldAnn, Ty) field = typeInner note  -- | 't_operator' parses tuples @(a, b, c)@, variants @(a | b | c)@, and also type expressions in -- parentheses @(a)@ and unit @()@. This is done this way for performance considerations. -- -- Consequently, 't_unit' doesn't bother with parsing @()@.-t_operator :: Parser FieldAnn -> Parser (FieldAnn, Ty)+t_operator :: Parser' le FieldAnn -> Parser le (FieldAnn, Ty) t_operator fp = do   whole <- parens do     optional do@@ -54,12 +61,14 @@   (f, t) <- fieldType fp   case whole of     Just (ty, Just (isOr, tys)) -> do+      assertLetEnv       let (f', Ty ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys)       f'' <- mergeAnnots f f'       return (f'', Ty ty' t)     Just (res, _) -> do       return res     Nothing -> do+      assertLetEnv       return (f, Ty TUnit t)   where     mergeTwo isOr _ (l, a) (r, b) =@@ -71,8 +80,8 @@       | otherwise = customFailure ExcessFieldAnnotation  typeInner-  :: Parser FieldAnn -> Parser (FieldAnn, Ty)-typeInner fp = label "type" $ lexeme $ choice $ (\x -> x fp) <$>+  :: Parser le FieldAnn -> Parser le (FieldAnn, Ty)+typeInner fp = label "type" $ choice $ (\x -> x fp) <$>   [ t_operator   , t_int, t_nat, t_string, t_bytes, t_mutez, t_bool   , t_keyhash, t_timestamp, t_address@@ -81,9 +90,15 @@   , t_option, t_list, t_set   , t_operation, t_contract, t_ticket, t_pair, t_or   , t_lambda, t_map, t_big_map, t_view-  , t_void, t_letType+  , t_void, t_letType'   , t_chestKey, t_chest+  , t_saplingState, t_saplingTransaction   ]+  where+    t_letType' :: forall le fp. Default fp => Parser' le fp -> Parser le (fp, Ty)+    t_letType' = case isLetEnv @le of+      Just Refl -> t_letType+      Nothing -> const mzero  ---------------------------------------------------------------------------- -- Non-comparable types@@ -93,107 +108,107 @@ mkType t (a, ta) = (a, Ty t ta)  -t_int :: (Default a) => Parser a -> Parser (a, Ty)+t_int :: (Default a) => Parser' le a -> Parser le (a, Ty) t_int fp = word' "Int" (mkType TInt) <*> fieldType fp -t_nat :: (Default a) => Parser a -> Parser (a, Ty)+t_nat :: (Default a) => Parser' le a -> Parser le (a, Ty) t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp -t_string :: (Default a) => Parser a -> Parser (a, Ty)+t_string :: (Default a) => Parser' le a -> Parser le (a, Ty) t_string fp = word' "String" (mkType TString) <*> fieldType fp -t_bytes :: (Default a) => Parser a -> Parser (a, Ty)+t_bytes :: (Default a) => Parser' le a -> Parser le (a, Ty) t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp -t_mutez :: (Default a) => Parser a -> Parser (a, Ty)+t_mutez :: (Default a) => Parser' le a -> Parser le (a, Ty) t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp -t_bool :: (Default a) => Parser a -> Parser (a, Ty)+t_bool :: (Default a) => Parser' le a -> Parser le (a, Ty) t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp -t_keyhash :: (Default a) => Parser a -> Parser (a, Ty)+t_keyhash :: (Default a) => Parser' le a -> Parser le (a, Ty) t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp -t_timestamp :: (Default a) => Parser a -> Parser (a, Ty)+t_timestamp :: (Default a) => Parser' le a -> Parser le (a, Ty) t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp -t_address :: (Default a) => Parser a -> Parser (a, Ty)+t_address :: (Default a) => Parser' le a -> Parser le (a, Ty) t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp -t_key :: (Default a) => Parser a -> Parser (a, Ty)+t_key :: (Default a) => Parser' le a -> Parser le (a, Ty) t_key fp = word' "Key" (mkType TKey) <*> fieldType fp -t_signature :: (Default a) => Parser a -> Parser (a, Ty)+t_signature :: (Default a) => Parser' le a -> Parser le (a, Ty) t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp -t_bls12381fr :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381fr :: (Default a) => Parser' le a -> Parser le (a, Ty) t_bls12381fr fp = do-  symbol' "bls12_381_fr" <|> symbol' "Bls12381Fr"+  symbol1' "bls12_381_fr" <|> symbol1' "Bls12381Fr"   mkType TBls12381Fr <$> fieldType fp -t_bls12381g1 :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381g1 :: (Default a) => Parser' le a -> Parser le (a, Ty) t_bls12381g1 fp = do-  symbol' "bls12_381_g1" <|> symbol' "Bls12381G1"+  symbol1' "bls12_381_g1" <|> symbol1' "Bls12381G1"   mkType TBls12381G1 <$> fieldType fp -t_bls12381g2 :: (Default a) => Parser a -> Parser (a, Ty)+t_bls12381g2 :: (Default a) => Parser' le a -> Parser le (a, Ty) t_bls12381g2 fp = do-  symbol' "bls12_381_g2" <|> symbol' "Bls12381G2"+  symbol1' "bls12_381_g2" <|> symbol1' "Bls12381G2"   mkType TBls12381G2 <$> fieldType fp -t_chestKey :: (Default a) => Parser a -> Parser (a, Ty)+t_chestKey :: (Default a) => Parser' le a -> Parser le (a, Ty) t_chestKey fp = do   symbol' "ChestKey" <|> symbol' "chest_key"   mkType TChestKey <$> fieldType fp -t_chest :: (Default a) => Parser a -> Parser (a, Ty)+t_chest :: (Default a) => Parser' le a -> Parser le (a, Ty) t_chest fp = word' "Chest" (mkType TChest) <*> fieldType fp -t_chain_id :: (Default a) => Parser a -> Parser (a, Ty)+t_chain_id :: (Default a) => Parser' le a -> Parser le (a, Ty) t_chain_id fp = do-  symbol' "ChainId" <|> symbol' "chain_id"+  symbol1' "ChainId" <|> symbol1' "chain_id"   mkType TChainId <$> fieldType fp -t_operation :: (Default a) => Parser a -> Parser (a, Ty)+t_operation :: (Default a) => Parser' le a -> Parser le (a, Ty) t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp -t_contract :: (Default a) => Parser a -> Parser (a, Ty)+t_contract :: (Default a) => Parser' le a -> Parser le (a, Ty) t_contract fp = do-  symbol' "Contract"+  symbol1' "Contract"   (f, t) <- fieldType fp   a <- type_   return (f, Ty (TContract a) t) -t_ticket :: (Default a) => Parser a -> Parser (a, Ty)+t_ticket :: (Default a) => Parser' le a -> Parser le (a, Ty) t_ticket fp = do-  symbol' "Ticket"+  symbol1' "Ticket"   (f, t) <- fieldType fp   a <- type_   return (f, Ty (TTicket a) t)  -- | Parses a @unit@ type. Unit type admits two variants of syntax, @unit@ and @()@. This parser -- handles only the former, the latter is handled in 't_operator'-t_unit :: (Default a) => Parser a -> Parser (a, Ty)+t_unit :: (Default a) => Parser' le a -> Parser le (a, Ty) t_unit fp = do-  symbol' "Unit"+  symbol1' "Unit"   (f,t) <- fieldType fp   return (f, Ty TUnit t) -t_never :: (Default a) => Parser a -> Parser (a, Ty)+t_never :: (Default a) => Parser' le a -> Parser le (a, Ty) t_never fp = do-  symbol' "Never" <|> symbol' "⊥"+  symbol1' "Never" <|> symbol1' "⊥"   (f,t) <- fieldType fp   return (f, Ty TNever t) -t_pair :: (Default a) => Parser a -> Parser (a, Ty)+t_pair :: (Default a) => Parser' le a -> Parser le (a, Ty) t_pair fp = do-  symbol' "Pair"+  symbol1' "Pair"   (fieldAnn, typeAnn) <- fieldType fp   fields <- many field   tPair <- go fields   pure $ (fieldAnn, Ty tPair typeAnn)   where-    go :: [(FieldAnn, Ty)] -> Parser T+    go :: [(FieldAnn, Ty)] -> Parser le T     go = \case       [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."       [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."@@ -203,26 +218,40 @@         rightCombedT <- go fields         pure $ TPair fieldAnnL noAnn noAnn noAnn typeL (Ty rightCombedT noAnn) -t_or :: (Default a) => Parser a -> Parser (a, Ty)+t_or :: (Default a) => Parser' le a -> Parser le (a, Ty) t_or fp = do-  symbol' "Or"+  symbol1' "Or"   (f, t) <- fieldType fp   (l, a) <- field   (r, b) <- field   return (f, Ty (TOr l r a b) t) -t_option :: (Default a) => Parser a -> Parser (a, Ty)+t_option :: (Default a) => Parser' le a -> Parser le (a, Ty) t_option fp = do-  symbol' "Option"+  symbol1' "Option"   (f, t) <- fieldType fp   a <- snd <$> typeInner (pure noAnn)   return (f, Ty (TOption a) t) -t_lambda :: (Default a) => Parser a -> Parser (a, Ty)+t_saplingState :: (Default a) => Parser' le a -> Parser le (a, Ty)+t_saplingState fp = do+  symbol1' "Sapling_state"+  (f,t) <- fieldType fp+  n <- lexeme L.decimal+  return (f, Ty (TSaplingState n) t)++t_saplingTransaction :: (Default a) => Parser' le a -> Parser le (a, Ty)+t_saplingTransaction fp = do+  symbol1' "Sapling_transaction"+  (f,t) <- fieldType fp+  n <- lexeme L.decimal+  return (f, Ty (TSaplingTransaction n) t)++t_lambda :: (Default a) => Parser' le a -> Parser le (a, Ty) t_lambda fp = core <|> slashLambda   where     core = do-      symbol' "Lambda"+      symbol1' "Lambda"       (f, t) <- fieldType fp       a <- type_       b <- type_@@ -232,54 +261,59 @@       (f, t) <- fieldType fp       a <- type_       symbol "->"+      assertLetEnv       b <- type_       return (f, Ty (TLambda a b) t)  -- Container types-t_list :: (Default a) => Parser a -> Parser (a, Ty)+t_list :: forall a le. (Default a) => Parser' le a -> Parser le (a, Ty) t_list fp = core <|> bracketList   where     core = do-      symbol' "List"+      symbol1' "List"       (f, t) <- fieldType fp       a <- type_       return (f, Ty (TList a) t)+    bracketList :: Parser le (a, Ty)     bracketList = do       a <- brackets type_+      assertLetEnv       (f, t) <- fieldType fp       return (f, Ty (TList a) t) -t_set :: (Default a) => Parser a -> Parser (a, Ty)+t_set :: forall a le. (Default a) => Parser' le a -> Parser le (a, Ty) t_set fp = core <|> braceSet   where     core = do-      symbol' "Set"+      symbol1' "Set"       (f, t) <- fieldType fp       a <- type_       return (f, Ty (TSet a) t)+    braceSet :: Parser le (a, Ty)     braceSet = do       a <- braces type_+      assertLetEnv       (f, t) <- fieldType fp       return (f, Ty (TSet a) t)  t_map_like-  :: Default a-  => Parser a -> Parser (Ty, Ty, a, TypeAnn)+  :: (Default a)+  => Parser' le a -> Parser le (Ty, Ty, a, TypeAnn) t_map_like fp = do   (f, t) <- fieldType fp   a <- type_   b <- type_   return (a, b, f, t) -t_map :: (Default a) => Parser a -> Parser (a, Ty)+t_map :: (Default a) => Parser' le a -> Parser le (a, Ty) t_map fp = do-  symbol' "Map"+  symbol1' "Map"   (a, b, f, t) <- t_map_like fp   return (f, Ty (TMap a b) t) -t_big_map :: (Default a) => Parser a -> Parser (a, Ty)+t_big_map :: (Default a) => Parser' le a -> Parser le (a, Ty) t_big_map fp = do-  symbol' "BigMap" <|> symbol "big_map"+  symbol1' "BigMap" <|> symbol1 "big_map"   (a, b, f, t) <- t_map_like fp   return (f, Ty (TBigMap a b) t) @@ -287,7 +321,7 @@ -- Non-standard types (Morley extensions) ---------------------------------------------------------------------------- -t_view :: Default a => Parser a -> Parser (a, Ty)+t_view :: (Default a) => Parser' le a -> Parser le (a, Ty) t_view fp = do   symbol' "View"   a <- type_@@ -296,7 +330,7 @@   let c' = Ty (TContract r) noAnn   return (f, Ty (TPair noAnn noAnn noAnn noAnn a c') t) -t_void :: Default a => Parser a -> Parser (a, Ty)+t_void :: (Default a) => Parser' le a -> Parser le (a, Ty) t_void fp = do   symbol' "Void"   a <- type_@@ -305,12 +339,12 @@   let c = Ty (TLambda b b) noAnn   return (f, Ty (TPair noAnn noAnn noAnn noAnn a c) t) -t_letType :: Default fp => Parser fp -> Parser (fp, Ty)+t_letType :: (Default fp) => Parser' LetEnv fp -> Parser' LetEnv (fp, Ty) t_letType fp = do   lts <- asks letTypes   lt <- ltSig <$> (mkLetType lts)   f <- parseDef fp   return (f, lt) -mkLetType :: Map Text LetType -> Parser LetType+mkLetType :: Map Text LetType -> Parser le LetType mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts)

@@ -1,33 +1,63 @@--- 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 -Wno-orphans #-}+ -- | Core parser types  module Morley.Michelson.Parser.Types   ( Parser+  , Parser'   , LetEnv (..)   , noLetEnv+  , HasLetEnv(..)+  , assertLetEnv+  , withLetEnv    , MichelsonSource (.., MSStdin, MSCli)   , codeSrc   ) where  import Data.Default (Default(..))-import qualified Data.Map as Map+import Data.Map qualified as Map+import Data.Type.Equality ((:~:)(Refl)) import Fmt (Buildable(..)) import GHC.Stack (SrcLoc(..))-import Text.Megaparsec (Parsec)+import Text.Megaparsec (Parsec, customFailure)  import Morley.Michelson.Let (LetType, LetValue) import Morley.Michelson.Macro (LetMacro) import Morley.Michelson.Parser.Error -type Parser = ReaderT LetEnv (Parsec CustomParserException Text)+type Parser a r = HasLetEnv a => Parser' a r+type Parser' a = ReaderT a (Parsec CustomParserException Text) -instance Default a => Default (Parser a) where+class HasLetEnv a where+  isLetEnv :: Maybe (a :~: LetEnv)++instance HasLetEnv LetEnv where+  isLetEnv = Just Refl++instance HasLetEnv () where+  isLetEnv = Nothing++assertLetEnv :: forall le. Parser le (le :~: LetEnv)+assertLetEnv = maybe (customFailure DeprecatedException) pure $ isLetEnv @le++withLetEnv :: forall le a. Parser' LetEnv a -> Parser le a+withLetEnv p = case isLetEnv @le of+  Just Refl -> p+  Nothing -> mzero++instance Default a => Default (Parser' le a) where   def = pure def +data ParserOptions = ParserOptions+  { poMorleyExts :: Bool+  } deriving stock (Show, Eq)+ -- | The environment containing lets from the let-block data LetEnv = LetEnv   { letMacros :: Map Text LetMacro@@ -35,8 +65,13 @@   , letTypes  :: Map Text LetType   } deriving stock (Show, Eq) +{-# DEPRECATED LetEnv "Let macros are deprecated" #-}+ noLetEnv :: LetEnv noLetEnv = LetEnv Map.empty Map.empty Map.empty++instance Default LetEnv where+  def = noLetEnv  -- | Where a contract or value in Michelson comes from. data MichelsonSource

@@ -1,7 +1,12 @@--- 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 #-}++-- TODO [#712]: Remove this next major release+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ -- | Parsing of untyped Michelson values.  module Morley.Michelson.Parser.Value@@ -16,22 +21,22 @@  import Prelude hiding (many, note, try) -import qualified Data.Char as Char-import qualified Data.Map as Map-import qualified Text.Hex as Hex+import Data.Char qualified as Char+import Data.Map qualified as Map+import Text.Hex qualified as Hex  import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try) import Text.Megaparsec.Char (char, string)-import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Char.Lexer qualified as L  import Morley.Michelson.Let (LetValue(..)) import Morley.Michelson.Macro (ParsedOp, ParsedValue) import Morley.Michelson.Parser.Error import Morley.Michelson.Parser.Helpers import Morley.Michelson.Parser.Lexer-import Morley.Michelson.Parser.Types (Parser, letValues)-import Morley.Michelson.Text (isMChar, unsafeMkMText)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', isLetEnv, letValues, withLetEnv)+import Morley.Michelson.Text (isMChar, mkMText)+import Morley.Michelson.Untyped qualified as U  {- Note [Exponential backtracking]@@ -61,36 +66,39 @@  -- | Parse untyped 'ParsedValue'. Take instruction parser as argument -- to avoid cyclic dependencies between modules, hence ' in its name.-value' :: Parser ParsedOp -> Parser ParsedValue-value' opParser = lexeme $ parensOrTuple opParser <|> valueInnerWithoutParens opParser+value' :: Parser le ParsedOp -> Parser le ParsedValue+value' opParser = parensOrTuple opParser <|> valueInnerWithoutParens opParser -parensOrTuple :: Parser ParsedOp -> Parser ParsedValue-parensOrTuple opParser = parens $ foldr1 U.ValuePair <$> value' opParser `sepBy1` comma+parensOrTuple :: forall le. Parser le ParsedOp -> Parser le ParsedValue+parensOrTuple opParser = parens $+  case isLetEnv @le of+    Just{} -> foldr1 U.ValuePair <$> value' opParser `sepBy1` comma+    Nothing -> value' opParser -valueInnerWithoutParens :: Parser ParsedOp -> Parser ParsedValue+valueInnerWithoutParens :: Parser le ParsedOp -> Parser le ParsedValue valueInnerWithoutParens opParser = label "value" $ choice $   [ stringLiteral, bytesLiteral, intLiteral, unitValue   , trueValue, falseValue, pairValueCore opParser, leftValue opParser   , rightValue opParser, someValue opParser, noneValue, nilValue-  , seqOrLambda opParser, mapValue opParser, dataLetValue+  , seqOrLambda opParser, mapValue opParser, withLetEnv dataLetValue   ] -seqOrLambda :: Parser ParsedOp -> Parser ParsedValue+seqOrLambda :: Parser le ParsedOp -> Parser le ParsedValue seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser -stringLiteral :: Parser ParsedValue-stringLiteral = U.ValueString . unsafeMkMText . toText <$> do+stringLiteral :: forall le. Parser le ParsedValue+stringLiteral = lexeme $ U.ValueString . unsafe . mkMText . toText <$> do   _ <- try $ string "\""   manyTill validChar (string "\"")   where-      validChar :: Parser Char+      validChar :: Parser le Char       validChar = choice         [ strEscape         , satisfy (\x -> x /= '"' && isMChar x)         , anySingle >>= stringLiteralFailure . InvalidChar         ] -      strEscape :: Parser Char+      strEscape :: Parser le Char       strEscape = try (char '\\') >> esc         where           esc = choice@@ -103,8 +111,8 @@  -- It is safe not to use `try` here because bytesLiteral is the only -- thing that starts from 0x (at least for now)-bytesLiteral :: Parser (U.Value' op)-bytesLiteral = do+bytesLiteral :: Parser le (U.Value' op)+bytesLiteral = lexeme $ do   string "0x"   hexdigits <- takeWhileP Nothing Char.isHexDigit   let mBytes = Hex.decodeHex hexdigits@@ -113,61 +121,61 @@     (return . U.ValueBytes . U.InternalByteString)     mBytes -intLiteral :: Parser (U.Value' op)-intLiteral = try $ U.ValueInt <$> L.signed pass L.decimal+intLiteral :: Parser le (U.Value' op)+intLiteral = lexeme $ try $ U.ValueInt <$> L.signed pass L.decimal -unitValue :: Parser ParsedValue+unitValue :: Parser le ParsedValue unitValue = word "Unit" U.ValueUnit -trueValue :: Parser ParsedValue+trueValue :: Parser le ParsedValue trueValue = word "True" U.ValueTrue -falseValue :: Parser ParsedValue+falseValue :: Parser le ParsedValue falseValue = word "False" U.ValueFalse -pairValueCore :: Parser ParsedOp -> Parser ParsedValue-pairValueCore opParser = symbol "Pair" *> pairInner+pairValueCore :: Parser le ParsedOp -> Parser le ParsedValue+pairValueCore opParser = symbol1 "Pair" *> pairInner   where     pairInner = U.ValuePair       <$> value' opParser       <*> (foldr1 U.ValuePair <$> some' (value' opParser)) -leftValue :: Parser ParsedOp -> Parser ParsedValue+leftValue :: Parser le ParsedOp -> Parser le ParsedValue leftValue opParser = word "Left" U.ValueLeft <*> value' opParser -rightValue :: Parser ParsedOp -> Parser ParsedValue+rightValue :: Parser le ParsedOp -> Parser le ParsedValue rightValue opParser = word "Right" U.ValueRight <*> value' opParser -someValue :: Parser ParsedOp -> Parser ParsedValue+someValue :: Parser le ParsedOp -> Parser le ParsedValue someValue opParser = word "Some" U.ValueSome <*> value' opParser -noneValue :: Parser ParsedValue+noneValue :: Parser le ParsedValue noneValue = word "None" U.ValueNone -nilValue :: Parser ParsedValue+nilValue :: Parser le ParsedValue nilValue = U.ValueNil <$ (try $ braces pass) -lambdaValue :: Parser ParsedOp -> Parser ParsedValue+lambdaValue :: forall le. Parser le ParsedOp -> Parser le ParsedValue lambdaValue opParser = U.ValueLambda <$> ops1   where-    ops1 :: Parser (NonEmpty ParsedOp)+    ops1 :: Parser le (NonEmpty ParsedOp)     ops1 = braces $ sepEndBy1 opParser semicolon -seqValue :: Parser ParsedOp -> Parser ParsedValue+seqValue :: Parser le ParsedOp -> Parser le ParsedValue seqValue opParser =   U.ValueSeq <$> (try $ braces $ sepEndBy1 (value' opParser) semicolon) -eltValue :: Parser ParsedOp -> Parser (U.Elt ParsedOp)+eltValue :: Parser le ParsedOp -> Parser le (U.Elt ParsedOp) eltValue opParser = word "Elt" U.Elt <*> value' opParser <*> value' opParser -mapValue :: Parser ParsedOp -> Parser ParsedValue+mapValue :: Parser le ParsedOp -> Parser le ParsedValue mapValue opParser =   U.ValueMap <$> (try $ braces $ sepEndBy1 (eltValue opParser) semicolon) -dataLetValue :: Parser ParsedValue+dataLetValue :: Parser' LetEnv ParsedValue dataLetValue = do   lvs <- asks letValues   lvVal <$> (mkLetVal lvs) -mkLetVal :: Map Text LetValue -> Parser LetValue+mkLetVal :: Map Text LetValue -> Parser le LetValue mkLetVal lvs = choice $ mkParser lvName <$> Map.elems lvs

@@ -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  -- | Apply some transformations to Michelson code. @@ -45,9 +44,9 @@   -- ^ Should transform only atomic values, 'dfsMapValue' will be applied to it.   -> Instr inp out   -> Instr inp out-transformConstants dsGoToValues f = fst . dfsInstr def{ dsGoToValues } step+transformConstants dsGoToValues f = dfsModifyInstr def{ dsGoToValues } step   where-    step :: forall i o. Instr i o -> (Instr i o, ())-    step = (,()) . \case+    step :: forall i o. Instr i o -> Instr i o+    step = \case       PUSH v -> PUSH (dfsMapValue f v)       i -> i

@@ -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 Morley.Michelson.Printer   ( RenderDoc(..)@@ -16,11 +15,11 @@  import Data.Constraint (withDict) import Data.Singletons (SingI)-import qualified Data.Text.Lazy as TL+import Data.Text.Lazy qualified as TL  import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc, renderAnyBuildable)-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  -- | Convert an untyped contract into a textual representation which -- will be accepted by the OCaml reference client: tezos-client.

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Utilities for rendering Michelson code in a format compatible with -- Tezos software (e.g @tezos-client@)@@ -29,7 +28,7 @@   ) where  import Control.Exception (assert)-import qualified Data.Text.Lazy as LT+import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder (Builder) import Fmt (Buildable, pretty) import Text.PrettyPrint.Leijen.Text@@ -73,6 +72,7 @@ -- instances of the combined value can have a different -- behavior for the pretty printer. newtype Prettier a = Prettier a+  deriving stock Functor  -- | Convert 'Doc' to 'Text' with a line width of 80. printDoc :: Bool -> Doc -> LT.Text

@@ -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  -- | Executor and typechecker of a contract in Morley language. @@ -17,6 +16,12 @@   , readAndParseContract   , prepareContract +  -- * Deprecated+  , parseContractExt+  , parseExpandContractExt+  , readAndParseContractExt+  , prepareContractExt+   -- * Re-exports   , ContractState (..)   , AddressState (..)@@ -29,6 +34,10 @@   -- * For testing   , ExecutorOp (..)   , ExecutorRes (..)+  , erGState+  , erUpdates+  , erInterpretResults+  , erRemainingSteps   , ExecutorError' (..)   , ExecutorError   , ExecutorM@@ -38,12 +47,14 @@   , executeGlobalOrigination   , executeOrigination   , executeTransfer--  -- * To avoid warnings (can't generate lenses only for some fields)-  , erInterpretResults-  , erUpdates-  , erGState-  , erRemainingSteps+  , ExecutorState(..)+  , esGState+  , esRemainingSteps+  , esSourceAddress+  , esLog+  , esOperationHash+  , esPrevCounters+  , ExecutorLog(..)   , elInterpreterResults   , elUpdates   ) where@@ -51,10 +62,10 @@ import Control.Lens (assign, at, makeLenses, (.=), (<>=)) import Control.Monad.Except (Except, liftEither, runExcept, throwError) import Data.Default (def)-import qualified Data.HashSet as HS-import Data.Semigroup.Generic+import Data.HashSet qualified as HS+import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) import Data.Text.IO (getContents)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Fmt (Buildable(build), blockListF, fmt, fmtLn, indentF, nameF, pretty, (+|), (|+)) import Text.Megaparsec (parse) @@ -62,21 +73,22 @@   (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),   RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret) import Morley.Michelson.Macro (ParsedOp, expandContract)-import qualified Morley.Michelson.Parser as P+import Morley.Michelson.Parser qualified as P import Morley.Michelson.Runtime.GState import Morley.Michelson.Runtime.TxData import Morley.Michelson.TypeCheck import Morley.Michelson.Typed-  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeContractAndStorage(..),-  SomeStorage(..), SomeValue(..), TransferTokens(..), untypeValue)-import qualified Morley.Michelson.Typed as T+  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeConstrainedValue(..),+  SomeContractAndStorage(..), SomeStorage, TransferTokens(..), untypeValue)+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation import Morley.Michelson.Untyped (Contract)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address(..), GlobalCounter(..), isKeyAddress) import Morley.Tezos.Core   (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez) import Morley.Tezos.Crypto (KeyHash, parseKeyHash)+import Morley.Util.MismatchError import Morley.Util.Named  ----------------------------------------------------------------------------@@ -123,7 +135,7 @@   -- are executed. In the end they are printed.   , _erRemainingSteps :: RemainingSteps   -- ^ Now much gas all remaining executions can consume.-  } deriving stock (Show)+  } deriving stock Show  data ExecutorEnv = ExecutorEnv   { _eeNow :: Timestamp@@ -177,7 +189,7 @@   -- ^ Failed to apply updates to GState.   | EEIllTypedParameter a TCError   -- ^ Contract parameter is ill-typed.-  | EEUnexpectedParameterType a T.T T.T+  | EEUnexpectedParameterType a (MismatchError T.T)   -- ^ Contract parameter is well-typed, but its type does   -- not match the entrypoint's type.   | EEUnknownEntrypoint EpName@@ -208,10 +220,9 @@         "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"       EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""       EEIllTypedParameter _ err -> "The contract parameter is ill-typed: " +| err |+ ""-      EEUnexpectedParameterType _ actualT expectedT ->-        "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>-        "Expected: " +| expectedT |+ "\n" <>-        "Got: " +| actualT |+ ""+      EEUnexpectedParameterType _ merr ->+        "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n"+        +| merr |+ ""       EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'"       EETransactionFromContract addr amount ->         "Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited."@@ -230,17 +241,57 @@ ----------------------------------------------------------------------------  -- | Parse a contract from 'Text'.-parseContract ::-     P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp)+parseContract+  :: P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp) parseContract source =   first P.ParserException . parse P.program (pretty source)  -- | Parse a contract from 'Text' and expand macros.-parseExpandContract ::-     P.MichelsonSource -> Text -> Either P.ParserException Contract+parseExpandContract+  :: P.MichelsonSource -> Text -> Either P.ParserException Contract parseExpandContract = fmap expandContract ... parseContract +-- TODO [#712]: Remove this next major release+-- | Parse a contract from 'Text' with Morley extensions.+parseContractExt+  :: P.MichelsonSource -> Text -> Either P.ParserException (U.Contract' ParsedOp)+parseContractExt source =+  first P.ParserException . parse P.programExt (pretty source)++-- TODO [#712]: Remove this next major release+-- | Parse a contract from 'Text' and expand macros with Morley extensions.+parseExpandContractExt+  :: P.MichelsonSource -> Text -> Either P.ParserException Contract+parseExpandContractExt = fmap expandContract ... parseContractExt++-- TODO [#712]: Remove this next major release -- | Read and parse a contract from give path or `stdin` (if the+-- argument is 'Nothing') with Morley extensions. The contract is not expanded.+readAndParseContractExt :: Maybe FilePath -> IO (U.Contract' ParsedOp)+readAndParseContractExt mFilename = do+  code <- readCode mFilename+  either throwM pure $ parseContractExt (toSrc mFilename) code+  where+    readCode :: Maybe FilePath -> IO Text+    readCode = maybe getContents Utf8.readFile++    toSrc :: Maybe FilePath -> P.MichelsonSource+    toSrc = maybe P.MSUnspecified P.MSFile+-- TODO [#712]: Remove this next major release+-- | Read a contract using 'readAndParseContract', expand and+-- flatten with Morley extensions. The contract is not type checked.+prepareContractExt :: Maybe FilePath -> IO Contract+prepareContractExt mFile = expandContract <$> readAndParseContractExt mFile+++{-# DEPRECATED+  parseContractExt,+  parseExpandContractExt,+  readAndParseContractExt,+  prepareContractExt+  "Morley extensions are deprecated" #-}++-- | Read and parse a contract from give path or `stdin` (if the -- argument is 'Nothing'). The contract is not expanded. readAndParseContract :: Maybe FilePath -> IO (U.Contract' ParsedOp) readAndParseContract mFilename = do@@ -303,10 +354,11 @@   -> "dryRun" :! Bool   -> IO SomeStorage runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData-  verbose (N dryRun) = do+  verbose (arg #dryRun -> dryRun) = do   origination <- either throwM pure . typeCheckingWith tcOpts $     mkOrigination <$> typeCheckContractAndStorage uContract uStorage-  (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do+  (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath+    (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do     -- Here we are safe to bypass executeGlobalOperations for origination,     -- since origination can't generate more operations.     addr <- executeGlobalOrigination origination@@ -422,7 +474,7 @@   -> ExecutorM a   -> IO (ExecutorRes, a) runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps-  (N verbose)+  (arg #verbose -> verbose)   (argDef #dryRun False -> dryRun)   action = do   gState <- readGState dbPath@@ -476,7 +528,7 @@               executeDelegation isGlobalOp operation               executeMany (#isGlobalOp :! False) opsTail             TransferOp transferOperation -> do-              moreOps <- executeTransfer isGlobalOp tcOpts transferOperation+              moreOps <- executeTransfer isGlobalOp Nothing tcOpts transferOperation               executeMany (#isGlobalOp :! False) $ moreOps <> opsTail  -- | Execute a global origination operation.@@ -488,7 +540,7 @@   :: "isGlobalOp" :! Bool   -> OriginationOperation   -> ExecutorM Address-executeOrigination (N isGlobalOp) origination@(OriginationOperation{..}) = do+executeOrigination (arg #isGlobalOp -> isGlobalOp) origination@(OriginationOperation{..}) = do   when isGlobalOp $ do     beginGlobalOperation     assign esOperationHash $ mkOriginationOperationHash origination@@ -501,7 +553,7 @@    -- Add big_map IDS to storage   let bigMapCounter0 = gs ^. gsBigMapCounterL-  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds ooStorage) bigMapCounter0+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds False ooStorage) bigMapCounter0    let contractState = ContractState ooBalance ooContract storageWithIds ooDelegate @@ -541,7 +593,7 @@   :: "isGlobalOp" :! Bool   -> SetDelegateOperation   -> ExecutorM ()-executeDelegation (N isGlobalOp) delegation@(SetDelegateOperation{..}) = do+executeDelegation (arg #isGlobalOp -> isGlobalOp) delegation@(SetDelegateOperation{..}) = do   when isGlobalOp $ do     beginGlobalOperation     assign esOperationHash $ mkDelegationOperationHash delegation@@ -562,10 +614,17 @@ -- | Execute a transfer operation. executeTransfer   :: "isGlobalOp" :! Bool+  -> Maybe Mutez+  -- ^ Whether to override the destination's balance.+  --+  -- When it's a `Just`, the destination's balance will be set to the given amount+  -- and no tz will be debited from the sender's account.+  -- This is useful to emulate the behaviour of the Tezos RPC's @/run_code@ endpoint.   -> TypeCheckOptions   -> TransferOperation   -> ExecutorM [ExecutorOp]-executeTransfer (N isGlobalOp) tcOpts transferOperation@(TransferOperation addr txData _) = do+executeTransfer (arg #isGlobalOp -> isGlobalOp)+  overrideBalanceMb tcOpts transferOperation@(TransferOperation addr txData _) = do     when isGlobalOp $       beginGlobalOperation @@ -589,16 +648,18 @@     -- Transferring 0 XTZ to a key address is prohibited.     when (isZeroTransfer && isKeyAddress addr) $       throwError $ EEZeroTransaction addr-    mDecreaseSenderBalance <- case (isZeroTransfer, addresses ^. at senderAddr) of-      (True, _) -> pure Nothing-      (False, Nothing) -> throwError $ EEUnknownSender senderAddr-      (False, Just (asBalance -> balance))-        | balance < tdAmount txData ->-          throwError $ EENotEnoughFunds senderAddr balance-        | otherwise ->-          -- Subtraction is safe because we have checked its-          -- precondition in guard.-          return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)+    mDecreaseSenderBalance <-+      if isNothing overrideBalanceMb && not isZeroTransfer+        then case addresses ^. at senderAddr of+          Nothing -> throwError $ EEUnknownSender senderAddr+          Just (asBalance -> balance)+            | balance < tdAmount txData ->+              throwError $ EENotEnoughFunds senderAddr balance+            | otherwise ->+              -- Subtraction is safe because we have checked its+              -- precondition in guard.+              return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData)+        else pure Nothing     when (not (isKeyAddress senderAddr) && isGlobalOp && not isZeroTransfer) $       throwError $ EETransactionFromContract senderAddr $ tdAmount txData     let onlyUpdates updates = return (updates, [], Nothing, remainingSteps)@@ -611,20 +672,29 @@           transferAmount = tdAmount txData           addrState = ASSimple transferAmount           upd = GSAddAddress addr addrState+         onlyUpdates [upd]       (Just (ASSimple oldBalance), _) -> do-        -- can't overflow if global state is correct (because we can't-        -- create money out of nowhere)         let-          newBalance = oldBalance `unsafeAddMutez` tdAmount txData+          -- Calculate the account's new balance, unless `overrideBalanceMb` is used.+          -- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't+          -- create money out of nowhere)+          newBalance =+            fromMaybe+              (oldBalance `unsafeAddMutez` tdAmount txData)+              overrideBalanceMb           upd = GSSetBalance addr newBalance         onlyUpdates [upd]       (Just (ASContract (ContractState {..})), _) -> do         let           existingContracts = extractAllContracts gs-          -- can't overflow if global state is correct (because we can't-          -- create money out of nowhere)-          newBalance = csBalance `unsafeAddMutez` tdAmount txData+          newBalance =+            -- Calculate the contract's new balance, unless `overrideBalanceMb` is used.+            -- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't+            -- create money out of nowhere)+            fromMaybe+              (csBalance `unsafeAddMutez` tdAmount txData)+              overrideBalanceMb           epName = tdEntrypoint txData          T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)@@ -644,7 +714,7 @@                 typeVerifyParameter @epArg existingContracts untypedVal          let bigMapCounter0 = gs ^. gsBigMapCounterL-        let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds typedParameter) bigMapCounter0+        let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds False typedParameter) bigMapCounter0          -- I'm not entirely sure why we need to pattern match on `()` here,         -- but, if we don't, we get a compiler error that I suspect is somehow related

@@ -1,6 +1,5 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA  -- | Dummy data to be used in tests or demos where it's not essential. @@ -20,10 +19,10 @@ import Morley.Michelson.Interpret (ContractEnv(..), RemainingSteps) import Morley.Michelson.Runtime.GState (BigMapCounter, dummyVotingPowers, genesisAddress) import Morley.Michelson.Typed (ParameterScope, StorageScope)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation (OriginationOperation(..)) import Morley.Tezos.Address (GlobalCounter(..))-import Morley.Tezos.Core (Timestamp(..), dummyChainId, toMutez)+import Morley.Tezos.Core (Timestamp(..), dummyChainId, tz)  -- | Dummy timestamp, can be used to specify current @NOW@ value or -- maybe something else.@@ -54,12 +53,12 @@ dummyContractEnv = ContractEnv   { ceNow = dummyNow   , ceMaxSteps = dummyMaxSteps-  , ceBalance = toMutez 100+  , ceBalance = [tz|100u|]   , ceContracts = mempty   , ceSelf = genesisAddress   , ceSource = genesisAddress   , ceSender = genesisAddress-  , ceAmount = toMutez 100+  , ceAmount = [tz|100u|]   , ceVotingPowers = dummyVotingPowers   , ceChainId = dummyChainId   , ceOperationHash = Nothing@@ -79,7 +78,7 @@ dummyOrigination storage contract counter = OriginationOperation   { ooOriginator = genesisAddress   , ooDelegate = Nothing-  , ooBalance = toMutez 100+  , ooBalance = [tz|100u|]   , ooStorage = storage   , ooContract = contract   , ooCounter = counter

@@ -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  -- | Global blockchain state (emulated). @@ -36,6 +35,7 @@   , genesisAddress4   , genesisAddress5   , genesisAddress6+  , genesisAddressN   , genesisKeyHash   -- * Genesis secret keys   , genesisSecretKey@@ -55,20 +55,19 @@  import Control.Lens (at, makeLenses) import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.:?), (.=))-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encode.Pretty as Aeson+import Data.Aeson qualified as Aeson+import Data.Aeson.Encode.Pretty qualified as Aeson import Data.Aeson.TH (deriveJSON)-import qualified Data.ByteString.Lazy as LBS+import Data.ByteString.Lazy qualified as LBS import Data.Default (def)-import Data.List.NonEmpty ((!!))-import qualified Data.Map.Strict as Map+import Data.Map.Strict qualified as Map import Data.Type.Equality ((:~:)(..))-import Fmt (Buildable(build), (+|), (|+))+import Fmt (Buildable(build), pretty, (+|), (|+)) import System.IO.Error (IOError, isDoesNotExistError)  import Morley.Michelson.TypeCheck   (SomeParamType(..), TcOriginatedContracts, typeCheckContractAndStorage, typeCheckingWith)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..)) import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped (Contract, Value)@@ -77,7 +76,10 @@ import Morley.Tezos.Crypto import Morley.Util.Aeson import Morley.Util.Lens-import Morley.Util.Sing (eqI)+import Morley.Util.Peano+import Morley.Util.Sing (eqI, eqParamSing, eqParamSing2)+import Morley.Util.SizedList qualified as SL+import Morley.Util.SizedList.Types  -- | State of a contract with code. data ContractState =@@ -94,6 +96,13 @@  deriving stock instance Show ContractState +instance Eq ContractState where+  ContractState b1 c1 s1 d1 == ContractState b2 c2 s2 d2 =+    b1 == b2+    && eqParamSing2 c1 c2+    && eqParamSing s1 s2+    && d1 == d2+ instance ToJSON ContractState where   toJSON ContractState{..} =     object .@@ -116,7 +125,7 @@       case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of         Right (SomeContractAndStorage contract storage) ->           pure $ ContractState balance contract storage delegate-        Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)+        Left err -> fail $ "Unable to parse `ContractState`: " <> pretty err  instance Buildable ContractState where   build ContractState{..} =@@ -132,7 +141,7 @@   | ASContract ContractState   -- ^ For contracts with code we store more state represented by   -- 'ContractState'.-  deriving stock (Show, Generic)+  deriving stock (Show, Eq, Generic)  instance Buildable AddressState where   build =@@ -158,7 +167,7 @@ -- exported. newtype VotingPowers   = VotingPowers (Map KeyHash Natural)-  deriving stock (Show)+  deriving stock (Show, Eq)  deriveJSON morleyAesonOptions ''VotingPowers @@ -203,62 +212,73 @@   , gsCounter :: GlobalCounter   -- ^ Ever increasing operation counter.   , gsBigMapCounter :: BigMapCounter-  } deriving stock (Show)+  } deriving stock (Show, Eq)  makeLensesWith postfixLFields ''GState  deriveJSON morleyAesonOptions ''GState --- | Number of genesis addresses.-genesisAddressesNum :: Word-genesisAddressesNum = 10+-- | Number of genesis addresses, type-level+type GenesisAddressesNum = 10 +-- | Convenience synonym+type GenesisList a = SizedList GenesisAddressesNum a++-- | Number of genesis addresses, term-level+genesisAddressesNum :: Natural+genesisAddressesNum = natVal @GenesisAddressesNum Proxy+ -- | Secrets from which genesis addresses are derived from.-genesisSecrets :: NonEmpty SecretKey-genesisSecrets = do-  i <- 1 :| [2 .. genesisAddressesNum]-  let seed = encodeUtf8 (show i :: Text)-  return $ detSecretKey seed+genesisSecrets :: GenesisList SecretKey+genesisSecrets = SL.generate @GenesisAddressesNum $ \i ->+    let seed = encodeUtf8 (show (i + 1) :: Text)+    in detSecretKey seed  -- | KeyHash of genesis address.-genesisKeyHashes :: NonEmpty KeyHash+genesisKeyHashes :: GenesisList KeyHash genesisKeyHashes = hashKey . toPublic <$> genesisSecrets  -- | Initially these addresses have a lot of money.-genesisAddresses :: NonEmpty Address+genesisAddresses :: GenesisList Address genesisAddresses = KeyAddress <$> genesisKeyHashes  -- | One of genesis key hashes. genesisKeyHash :: KeyHash-genesisKeyHash = head genesisKeyHashes+genesisKeyHash = SL.head genesisKeyHashes  -- | One of genesis addresses. genesisAddress :: Address-genesisAddress = head genesisAddresses+genesisAddress = SL.head genesisAddresses  -- | Secret key assotiated with 'genesisAddress'. genesisSecretKey :: SecretKey-genesisSecretKey = head genesisSecrets+genesisSecretKey = SL.head genesisSecrets  -- | More genesis addresses------ We know size of @genesisAddresses@, so it is safe to use @!!@ genesisAddress1, genesisAddress2, genesisAddress3 :: Address genesisAddress4, genesisAddress5, genesisAddress6 :: Address-genesisAddress1 = genesisAddresses !! 1-genesisAddress2 = genesisAddresses !! 2-genesisAddress3 = genesisAddresses !! 3-genesisAddress4 = genesisAddresses !! 4-genesisAddress5 = genesisAddresses !! 5-genesisAddress6 = genesisAddresses !! 6+_ :< genesisAddress1 :< genesisAddress2 :< genesisAddress3+  :< genesisAddress4 :< genesisAddress5 :< genesisAddress6+  :< _ = genesisAddresses +{-# DEPRECATED genesisAddress4, genesisAddress5, genesisAddress6+               "Consider using 'genesisAddressN' instead" #-}++-- | More genesis addresses, via a type-level natural+--+-- > genesisAddressN @7+--+-- Note that @'genesisAddress' == genesisAddressN \@0@, @'genesisAddress1' == genesisAddressN \@1@,+-- etc.+genesisAddressN :: forall n. (SingIPeano n, ToPeano GenesisAddressesNum > ToPeano n ~ 'True) => Address+genesisAddressN = SL.index @n genesisAddresses+ -- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses -- as the addresses holding lot of money. Only two addresses are involved for -- simplicity. dummyVotingPowers :: VotingPowers dummyVotingPowers = case genesisKeyHashes of-  k1 :| k2 : _ -> mkVotingPowers [(k1, 50), (k2, 50)]-  _ -> error "Insufficient number of genesis addresses"+  k1 :< k2 :< _ -> mkVotingPowers [(k1, 50), (k2, 50)]  -- | Initial 'GState'. It's supposed to be used if no 'GState' is -- provided. It puts plenty of money on each genesis address.@@ -429,5 +449,5 @@       \case (KeyAddress _, ASSimple {}) -> Nothing             (KeyAddress _, _) -> error "broken GState"             (ContractAddress ca, ASContract (ContractState{..})) ->-              Just (ca, SomeParamType sing $ T.cParamNotes $ csContract)+              Just (ca, SomeParamType $ T.cParamNotes $ csContract)             (ContractAddress _, _) -> error "broken GState"

@@ -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 Morley.Michelson.Runtime.Import   (     -- * Read, parse, typecheck contract@@ -12,6 +14,9 @@   , importSomeContract   , importUntypedContract   , ContractReadError(..)+  , readUntypedContractExt+  , readContractExt+  , readSomeContractExt      -- * Read, parse, typecheck value   , readValue@@ -26,18 +31,18 @@   ) where  import Data.Default (def)-import qualified Data.Text.IO.Utf8 as Utf8 (readFile)+import Data.Text.IO.Utf8 qualified as Utf8 (readFile) import Fmt (Buildable(build), pretty, unlessF, (+|), (|+))  import Morley.Michelson.Parser (parseExpandValue) import Morley.Michelson.Parser.Error (ParserException(..)) import Morley.Michelson.Parser.Types (MichelsonSource(..))-import Morley.Michelson.Runtime (parseExpandContract)+import Morley.Michelson.Runtime (parseExpandContract, parseExpandContractExt) import Morley.Michelson.TypeCheck   (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract,   typeVerifyTopLevelType) import Morley.Michelson.Typed (Contract, SingI, SomeContract(..), SomeValue, Value)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U  ---------------------------------------------------------------------------- -- Reading, parsing, typechecking contract@@ -45,7 +50,7 @@  -- | Purely read an untyped contract from Michelson textual representation. ----- 'FilePath' is accepted solely as a hint for error messages.+-- 'MichelsonSource' is accepted solely as a hint for error messages. readUntypedContract   :: MichelsonSource   -> Text@@ -53,6 +58,20 @@ readUntypedContract source txt = do   first (CREParse source) $ parseExpandContract source txt +-- TODO [#712]: Remove this next major release+-- | Purely read an untyped contract from Michelson textual representation+-- with Morley extensions.+--+-- 'MichelsonSource' is accepted solely as a hint for error messages.+readUntypedContractExt+  :: MichelsonSource+  -> Text+  -> Either ContractReadError U.Contract+readUntypedContractExt source txt = do+  first (CREParse source) $ parseExpandContractExt source txt++{-# DEPRECATED readUntypedContractExt "Morley extensions are deprecated" #-}+ -- | Purely read a typed contract from Michelson textual representation. readSomeContract   :: MichelsonSource@@ -63,6 +82,20 @@   first (CRETypeCheck source) $     typeCheckingWith def $ typeCheckContract contract +-- TODO [#712]: Remove this next major release+-- | Purely read a typed contract from Michelson textual representation+-- with Morley extensions.+readSomeContractExt+  :: MichelsonSource+  -> Text+  -> Either ContractReadError SomeContract+readSomeContractExt source txt = do+  contract <- readUntypedContractExt source txt+  first (CRETypeCheck source) $+    typeCheckingWith def $ typeCheckContract contract++{-# DEPRECATED readSomeContractExt "Morley extensions are deprecated" #-}+ -- | Purely read a typed contract from Michelson textual representation, -- failing if parameter or storage types mismatch with the expected ones. readContract@@ -75,6 +108,23 @@   contract <- readUntypedContract source txt   first (CRETypeCheck source) $     typeCheckingWith def $ typeVerifyContract contract++-- TODO [#712]: Remove this next major release+-- | Purely read a typed contract from Michelson textual representation+-- with Morley extensions,+-- failing if parameter or storage types mismatch with the expected ones.+readContractExt+  :: forall cp st .+     Each '[SingI] [cp, st]+  => MichelsonSource+  -> Text+  -> Either ContractReadError (Contract cp st)+readContractExt source txt = do+  contract <- readUntypedContractExt source txt+  first (CRETypeCheck source) $+    typeCheckingWith def $ typeVerifyContract contract++{-# DEPRECATED readContractExt "Morley extensions are deprecated" #-}  -- | Read a thing from a file, using the provided parsing function. importUsing

@@ -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  -- | 'TxData' type and associated functionality. @@ -16,9 +15,9 @@ import Control.Lens (makeLensesWith)  import Morley.Michelson.Typed (ParameterScope)-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped (EpName)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) import Morley.Tezos.Core (Mutez) import Morley.Util.Lens (postfixLFields)

@@ -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  -- deriving 'Container' automatically produces extra constraints. {-# OPTIONS_GHC -Wno-redundant-constraints #-}@@ -19,7 +18,6 @@ module Morley.Michelson.Text   ( MText (..)   , mkMText-  , unsafeMkMText   , mkMTextCut   , writeMText   , takeMText@@ -38,12 +36,12 @@   ) where  import Data.Aeson (FromJSON(..), ToJSON(..))-import qualified Data.Char as C+import Data.Char qualified as C import Data.Data (Data)-import qualified Data.Text as T+import Data.Text qualified as T import Fmt (Buildable)-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Quote as TH+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Quote qualified as TH  import Morley.Util.CLI import Morley.Util.Label (Label(..), labelToText)@@ -65,7 +63,7 @@ -- -- * With 'mkMText' when constructing from a runtime text value. ----- * With 'unsafeMkMText' or 'UnsafeMText' when absolutelly sure that+-- * With 'UnsafeMText' when absolutelly sure that -- given string does not violate invariants. -- -- * With 'mkMTextCut' when not sure about text contents and want@@ -99,11 +97,6 @@       | isMChar c || c == '\n' = pass       | otherwise = Left $ invalidMCharError c --- | Contruct 'MText' from a Haskell text, failing if provided Haskell text--- is invalid Michelson string.-unsafeMkMText :: HasCallStack => Text -> MText-unsafeMkMText = either error id . mkMText- -- | Construct 'MText' from a Haskell text, eliminating all characters which -- should not appear in Michelson strings. -- Characters which can be displayed normally via escaping are preserved.@@ -198,14 +191,14 @@ -- We assume that no unicode characters are used in plain Haskell code, -- so unless special tricky manipulations are used this should be safe. symbolToMText :: forall name. KnownSymbol name => MText-symbolToMText = unsafeMkMText $ symbolValT' @name+symbolToMText = unsafe . mkMText $ symbolValT' @name  -- | Create a 'MText' from label. -- -- We assume that no unicode characters are used in plain Haskell code, -- so unless special tricky manipulations are used this should be safe. labelToMText :: Label name -> MText-labelToMText = unsafeMkMText . labelToText+labelToMText = unsafe . mkMText . labelToText  -- | Leads first character of text to upper case. --

@@ -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 Morley.Michelson.TypeCheck   ( typeCheckContract@@ -17,6 +16,7 @@   , typeVerifyParameter   , typeVerifyStorage   , typeVerifyTopLevelType+  , typeVerifyView   , module E   , module M   , module 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  -- | Errors that can occur when some code is being typechecked. @@ -15,10 +14,11 @@   , pairWithElems   ) where -import Fmt (Buildable(..), pretty, (+|), (|+), (||+))+import Fmt (Buildable(..), pretty, (+|), (|+)) import Prelude hiding (empty, (<$>))-import Text.PrettyPrint.Leijen.Text hiding (bool, pretty)-import qualified Text.Show (show)+import Text.PrettyPrint.Leijen.Text+  (Doc, cat, enclose, indent, line, list, punctuate, textStrict, (<$$>), (<$>), (<+>))+import Text.Show qualified (show)  import Morley.Michelson.ErrorPos (InstrCallStack(..)) import Morley.Michelson.Printer.Util@@ -26,14 +26,14 @@   renderDoc, renderDocList) import Morley.Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp) import Morley.Michelson.TypeCheck.Types (SomeHST(..))-import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Annotation (AnnConvergeError(..)) import Morley.Michelson.Untyped (StackFn, Ty, Var)-import qualified Morley.Michelson.Untyped as U+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address) import Morley.Tezos.Crypto (CryptoParseError)-import qualified Morley.Tezos.Crypto.BLS12381 as BLS-import Morley.Util.Named+import Morley.Tezos.Crypto.BLS12381 qualified as BLS+import Morley.Util.MismatchError  -- | Contexts where type error can occur. data TypeContext@@ -107,9 +107,9 @@ data TCTypeError   = AnnError AnnConvergeError   -- ^ Annotation unify error-  | TypeEqError T.T T.T+  | TypeEqError (MismatchError T.T)   -- ^ Type equality error-  | StackEqError [T.T] [T.T]+  | StackEqError (MismatchError [T.T])   -- ^ Stacks equality error   | UnsupportedTypeForScope T.T T.BadTypeForScope   -- ^ Error that happens when type cannot be used in the corresponding scope.@@ -123,7 +123,7 @@   -- ^ Error that happens when actual types are different from the type that instruction expects.   -- The param is an non-empty list of all expected stack types that the instruction would accept.   -- Each expected stack types is represented as non-empty list as well.-  | UnexpectedTopLevelType TopLevelType ("expected" :! T.T) ("got" :! T.T)+  | UnexpectedTopLevelType TopLevelType (MismatchError T.T)   -- ^ Error that happens when the caller expected one top-level type, but   -- the contract has another type specified.   | InvalidInstruction U.ExpandedInstr Text@@ -172,10 +172,10 @@ instance RenderDoc TCTypeError where   renderDoc context = \case     AnnError e -> renderAnyBuildable e-    TypeEqError type1 type2 ->-      "Types not equal:" <+> (renderDoc context type1) <+> "/=" <+> (renderDoc context type2)-    StackEqError st1 st2 ->-      "Stacks not equal:"<+> (renderDocList context st1) <+> "/=" <+> (renderDocList context st2)+    TypeEqError merr ->+      "Types not equal:" <$> renderDoc context merr+    StackEqError merr ->+      "Stacks not equal:" <$> renderDoc context merr     UnsupportedTypeForScope typ reason ->       "Type '" <> (renderDoc context typ) <> "' is unsupported here because it"       <+> (renderDoc context reason)@@ -188,11 +188,9 @@           $ fmap (\(x :| xs) -> list $ fmap (renderAnyBuildable) (x:xs))           $ (t:ts)         )-    UnexpectedTopLevelType tyDesc (N expected) (N got) ->-      "Unexpected" <+> renderDoc context tyDesc <+> "type:"-      <$$> renderLargeType got-      <$$> "Expected:"-      <$$> renderLargeType expected+    UnexpectedTopLevelType tyDesc mmerr ->+      "Unexpected" <+> renderDoc context tyDesc <+> "type."+      <$$> renderDoc doesntNeedParens mmerr     InvalidInstruction instr reason ->       "Invalid instruction" <+> (renderDoc context instr)       <$$> "Reason:" <+> textStrict reason@@ -216,9 +214,6 @@       "Cannot use a terminate instruction (like FAILWITH) in this block"     EmptyCode -> "Code block is empty"     AnyError -> "Some of the arguments have invalid types"-    where-      renderLargeType :: T.T -> Doc-      renderLargeType = indent 2 . renderDoc doesntNeedParens . T.toUType  -- | Type check error data TCError@@ -229,6 +224,7 @@   | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)   | TCExtError SomeHST InstrCallStack ExtError   | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)+  | TCIncompletelyTypedView TCError (U.View' TypeCheckedOp)   deriving stock (Eq, Generic)  instance NFData TCError@@ -269,6 +265,9 @@       line       <> renderDoc doesntNeedParens contract       <$> renderDoc context err+    TCIncompletelyTypedView err _view ->+      line+      <> renderDoc context err     where     buildTruncated k l       | null (drop k l) = renderDocList context l@@ -292,6 +291,9 @@  instance NFData StackSize +instance Buildable StackSize where+  build (StackSize n) = "stack size " +| n |+ ""+ -- | Various type errors possible when checking Morley extension commands data ExtError =     LengthMismatch U.StackTypePattern@@ -323,13 +325,13 @@       +| i |+ " with error: " +| e |+ ""     StkRestMismatch stk (SomeHST r) (SomeHST r') e ->       "StkRestMismatch in pattern " +| stk |+-      " against stacks " +| r ||+ " and " +| r' ||++      " against stacks " +| r |+ " and " +| r' |+       " with error: " +| e |+ ""     TestAssertError t ->       "TestAssertError: " +| t |+ ""     InvalidStackReference i lhs ->       "InvalidStackReference: reference is out of the stack: "-      +| i ||+ " >= " +| lhs ||+ ""+      +| i |+ " >= " +| lhs |+ ""  ---------------------------------------------------------------------------- -- Helpers for formatting types