morley 1.19.0 → 1.19.1
raw patch · 70 files changed
+3684/−2209 lines, 70 filesdep +hsblst
Dependencies added: hsblst
Files
- CHANGES.md +105/−0
- LICENSE +1/−1
- README.md +13/−2
- app/Main.hs +250/−289
- app/REPL.hs +2/−7
- morley.cabal +12/−2
- src/Morley/AsRPC.hs +75/−98
- src/Morley/CLI.hs +9/−0
- src/Morley/Micheline/Binary/Internal.hs +3/−16
- src/Morley/Micheline/Class.hs +6/−2
- src/Morley/Micheline/Expression.hs +2/−1
- src/Morley/Michelson/Internal/ViewName.hs +94/−0
- src/Morley/Michelson/Internal/ViewsSet.hs +70/−0
- src/Morley/Michelson/Interpret.hs +243/−145
- src/Morley/Michelson/Macro.hs +39/−62
- src/Morley/Michelson/Optimizer.hs +323/−260
- src/Morley/Michelson/Optimizer/Internal/Proofs.hs +76/−0
- src/Morley/Michelson/Parser.hs +6/−1
- src/Morley/Michelson/Parser/Instr.hs +7/−0
- src/Morley/Michelson/Parser/Type.hs +2/−2
- src/Morley/Michelson/Runtime.hs +373/−194
- src/Morley/Michelson/Runtime/Dummy.hs +4/−3
- src/Morley/Michelson/Runtime/GState.hs +85/−17
- src/Morley/Michelson/Runtime/RunCode.hs +5/−4
- src/Morley/Michelson/TypeCheck/Error.hs +2/−5
- src/Morley/Michelson/TypeCheck/Helpers.hs +27/−15
- src/Morley/Michelson/TypeCheck/Instr.hs +78/−35
- src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs +8/−4
- src/Morley/Michelson/TypeCheck/Value.hs +17/−13
- src/Morley/Michelson/Typed/Annotation.hs +0/−5
- src/Morley/Michelson/Typed/Arith.hs +104/−1
- src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs +2/−1
- src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs +2/−1
- src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs +2/−1
- src/Morley/Michelson/Typed/Contract.hs +52/−19
- src/Morley/Michelson/Typed/Convert.hs +40/−78
- src/Morley/Michelson/Typed/Extract.hs +0/−3
- src/Morley/Michelson/Typed/Haskell/Doc.hs +81/−40
- src/Morley/Michelson/Typed/Haskell/Instr/Product.hs +3/−3
- src/Morley/Michelson/Typed/Haskell/Value.hs +0/−5
- src/Morley/Michelson/Typed/Instr.hs +165/−185
- src/Morley/Michelson/Typed/Instr/Constraints.hs +175/−0
- src/Morley/Michelson/Typed/Instr/Internal/Proofs.hs +194/−0
- src/Morley/Michelson/Typed/Operation.hs +25/−0
- src/Morley/Michelson/Typed/Scope.hs +72/−147
- src/Morley/Michelson/Typed/T.hs +0/−2
- src/Morley/Michelson/Typed/Util.hs +7/−16
- src/Morley/Michelson/Typed/Value.hs +0/−3
- src/Morley/Michelson/Typed/View.hs +21/−49
- src/Morley/Michelson/Untyped/Contract.hs +85/−71
- src/Morley/Michelson/Untyped/Instr.hs +55/−47
- src/Morley/Michelson/Untyped/Type.hs +33/−53
- src/Morley/Michelson/Untyped/Value.hs +3/−3
- src/Morley/Michelson/Untyped/View.hs +34/−67
- src/Morley/Tezos/Address.hs +57/−88
- src/Morley/Tezos/Address/Alias.hs +14/−11
- src/Morley/Tezos/Address/Kinds.hs +13/−3
- src/Morley/Tezos/Crypto.hs +102/−64
- src/Morley/Tezos/Crypto/BLS.hs +202/−0
- src/Morley/Tezos/Crypto/Util.hs +9/−5
- src/Morley/Util/CLI.hs +1/−1
- src/Morley/Util/Interpolate/Internal.hs +3/−5
- src/Morley/Util/Named.hs +6/−1
- src/Morley/Util/Peano.hs +33/−36
- src/Morley/Util/PeanoNatural.hs +5/−1
- src/Morley/Util/SizedList.hs +7/−4
- src/Morley/Util/StubbedProof.hs +35/−0
- src/Morley/Util/Text.hs +96/−1
- src/Morley/Util/Type.hs +9/−7
- src/Morley/Util/TypeLits.hs +0/−4
CHANGES.md view
@@ -1,6 +1,111 @@ <!-- Unreleased: append new entries here --> +1.19.1+======+* [!1325](https://gitlab.com/morley-framework/morley/-/merge_requests/1325)+ Add `AND`, `NOT`, `OR`, `XOR`, `LSL` and `LSR` operations support on `bytes`+* [!1326](https://gitlab.com/morley-framework/morley/-/merge_requests/1326)+ Add support for bytes to nat and int conversions+ + Support `NAT` and `BYTES` instructions, and the new operands to `INT`+ instruction.+* [!1331](https://gitlab.com/morley-framework/morley/-/merge_requests/1331)+ Support implicit account tickets+ + New `emulate transfer-ticket` CLI command+ + Add `CheckScope` instance for constraint pairs+* [!1330](https://gitlab.com/morley-framework/morley/-/merge_requests/1330)+ Support ticket balance queries in morley-client and Cleveland.+ + Add `HasCLReader` instance for `Ty`.+* [!1328](https://gitlab.com/morley-framework/morley/-/merge_requests/1328)+ Kill support for TORUs, minimal sr1 address support, tz4 address support+ + `txr1` addresses and `tx_rollup_l2_address` are no longer parsable;+ + `sr1` addresses can be parsed and typechecked, but sending transfers to+ `sr1` is not yet supported in the Morley runtime;+ + Full support for `tz4` addresses.+* [!1322](https://gitlab.com/morley-framework/morley/-/merge_requests/1322)+ Various optimizer improvements+ + Reapply optimizer stages until fixpoint (up to a configurable maximum of+ iterations);+ + Rework optimizer ruleset architecture;+ + Drop `Meta` and `WithLoc` during optimization;+ + Apply `dipDrop2swapDrop` in a separate stage;+ + More complete optimization for `DROPN`, `PAIRN`, `UNPAIRN`, `DIPN` and+ nested `DIP`s;+ + Optimize `DIG 1` and `DUG 1` to `SWAP`;+ + Optimize `NOT; IF a b` to `IF b a`;+ + The last one requires carrying `SingI` constraint on the argument of `NOT`,+ so do that.+* [!1298](https://gitlab.com/morley-framework/morley/-/merge_requests/1298)+ Handle view ordering properly+ + Also deprecates some unused functions and cleans up macro expansion code+ + Specifically, typed `mapEntriesOrdered`; `mapContractCode`, and `expandList`+ are deprecated+* [!1313](https://gitlab.com/morley-framework/morley/-/merge_requests/1313)+ Generalize `ceContracts` to a function+ + Allows performing arbitrary actions to fetch contracts+ + `ContractEnv` is now parametrized by the interpreter monad+ + As a side effect, interpreter monad needs to be a newtype now+* [!1315](https://gitlab.com/morley-framework/morley/-/merge_requests/1315)+ Slightly generalize `L1AddressKind` type synonym+* [!1295](https://gitlab.com/morley-framework/morley/-/merge_requests/1295)+ Replace FrameInstr with a function+ + Also:+ + Move instruction constraints to `Morley.Michelson.Typed.Instr.Constraints`;+ + Add utilities for stubbing proofs;+ + Deprecate unused and unsafe things: `(|-)`, `failUnlessEvi`, `failWhenEvi`,+ `unsafeProvideConstraint`, `listOfTypesConcatAssociativityAxiom`;+ + General cleanup.+* [!1312](https://gitlab.com/morley-framework/morley/-/merge_requests/1312)+ Add WellTyped constraint to sampleTypedValue+* [!1311](https://gitlab.com/morley-framework/morley/-/merge_requests/1311)+ Add missing HasCLReader instances for address types+* [!1309](https://gitlab.com/morley-framework/morley/-/merge_requests/1309)+ Don't render untyped pairs as sequences+* [!1308](https://gitlab.com/morley-framework/morley/-/merge_requests/1308)+ Improve contract rendering+ + If the type fits into the column width, print it in one line.+ + If it doesn't, print arguments on separate lines with indent 2.+ + For types with very short prefix before arguments, render the first argument+ on the current line, and align all the rest with the first.+ + Apply the same basic rules to instructions and on-chain views.+* [!1182](https://gitlab.com/morley-framework/morley/-/merge_requests/1182)+ Add `metaWrapper` to `ContractEnv` which build a wrapper attaching `Meta` and+ `WithLoc` along the way. This wrapper the is used when it meets loop instruction.+* [!1305](https://gitlab.com/morley-framework/morley/-/merge_requests/1305)+ Add a recommendation to morley's `README.md` for the user to include the `extra-deps` if they have difficulty building `morley`.+* [!1299](https://gitlab.com/morley-framework/morley/-/merge_requests/1299)+ Fix recursive deriveRPC for Address, Lorentz Hash and other types with phantom+ arguments.+* [!1239](https://gitlab.com/morley-framework/morley/-/merge_requests/1239)+ Give Seq a fixity declaration+ + The same as `:#`, i.e. `infixr 8`.+* [!1235](https://gitlab.com/morley-framework/morley/-/merge_requests/1235)+ Make it easier to have consistent field naming between HasAnnotation and TypeHasDoc+ + Move all casing manipulation to `Morley.Util.Text`.+ + Use new casing manipulation functions everywhere.+ + Introduce `TypeHasFieldNamingStrategy` -- a typeclass with a catchall+ overlappable instance, which defines the strategy to use. Strategy being a+ function `Text -> Text` modifying field names.+ + Require `TypeHasFieldNamingStrategy` constraint in the default+ implementation of `typeDocHaskellRep`. Apply the strategy as appropriate.+ + See also the corresponding `lorentz` changelog.+* [!1280](https://gitlab.com/morley-framework/morley/-/merge_requests/1280)+ Export everything from internal modules+ + That includes `Morley.Micheline.Binary.Internal` and+ `Morley.Util.Interpolate.Internal`.+* [!1264](https://gitlab.com/morley-framework/morley/-/merge_requests/1264)+ Add view calling to morley runtime and CLI (plus some chores)+ + Add `HasCLReader ViewName` instance+ + Refactor `Morley.Michelson.Runtime` interface to reduce the number of+ arguments functions take in favor of records and/or `Named` arguments.+ + Refactor `Morley.Michelson.Interpret`, replacing+ `InterpretResult`/`ContractReturn` system with `ResultStateLogs` and a+ hierarchy of synonyms built on top. See [this commit+ description](https://gitlab.com/morley-framework/morley/-/commit/7ba88554209c99fad7a7dabd3731d0526169a673)+ for more information.+ + As a chore, add `Default` instance for `Named` parameters, so that `def` can+ be used in place of `Named.defaults`.+ 1.19.0 ====== * [!1273](https://gitlab.com/morley-framework/morley/-/merge_requests/1273)
LICENSE view
@@ -1,5 +1,5 @@ MIT License-Copyright (c) 2021-2022 Oxhead Alpha+Copyright (c) 2021-2023 Oxhead Alpha Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy
README.md view
@@ -1,3 +1,7 @@+> :warning: **Note: this project is being deprecated.**+>+> It will no longer be maintained after the activation of protocol "N" on the Tezos mainnet.+ # Morley: Developer tools for the Michelson Language [](https://hackage.haskell.org/package/morley)@@ -62,13 +66,20 @@ + You want to print a contract on a single line. - `parse` a contract and return its representation in Haskell types. +NOTE: `$TERM` and `$TERMINFO` environment variables need to be set for an enhanced terminal experience when using utilities like+`repl`+ You can get more info about these commands by running `morley <command> --help`. Run `morley --help` to get the list of all commands. ## Morley library -Morley-the library is available on [Hackage](https://hackage.haskell.org/package/morley).-It consists of the following parts:+Morley-the library is available on [Hackage](https://hackage.haskell.org/package/morley). To use `morley` as library, simply include it in the `package.yaml`.++It is recommended to also+add `morley` extra-deps to your `stack.yaml`. The extra-deps can be found [here](../../stack.yaml#L25-62).++The library consists of the following parts: - The `Morley.Tezos.*` hierarchy ([`Morley.Tezos.Address`](http://hackage.haskell.org/package/morley/docs/Morley-Tezos-Address.html), [`Morley.Tezos.Core`](http://hackage.haskell.org/package/morley/docs/Morley-Tezos-Core.html), [`Morley.Tezos.Crypto`](http://hackage.haskell.org/package/morley/docs/Morley-Tezos-Crypto.html)) is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts but is used not only by Michelson. - [`Morley.Michelson.Untyped`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Untyped.html) and [`Morley.Michelson.Typed`](http://hackage.haskell.org/package/morley/docs/Morley-Michelson-Typed.html) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](https://gitlab.com/morley-framework/morley/-/blob/master/code/morley/docs/michelsonTypes.md).
app/Main.hs view
@@ -5,9 +5,12 @@ ( main ) where +import Data.Default (def)+import Data.Singletons (demote) import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile) import Data.Version (showVersion)-import Fmt (pretty)+import Fmt (pretty, unlinesF)+import Named (paramF) import Options.Applicative (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short, subparser, switch)@@ -18,266 +21,285 @@ import Morley.CLI import Morley.Michelson.Analyzer (analyze)-import Morley.Michelson.Optimizer (optimize)-import Morley.Michelson.Printer (printSomeContract, printUntypedContract)+import Morley.Michelson.Interpret (RemainingSteps(..))+import Morley.Michelson.Optimizer (OptimizerConf(..), optimizeVerboseWithConf)+import Morley.Michelson.Printer (printSomeContract, printTypedContract, printUntypedContract) import Morley.Michelson.Runtime- (TxData(..), originateContract, prepareContract, runContract, transfer) import Morley.Michelson.Runtime.GState (genesisAddress)-import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)+import Morley.Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckValue, typeCheckingWith) import Morley.Michelson.TypeCheck qualified as TypeCheck-import Morley.Michelson.TypeCheck.Types (mapSomeContract) import Morley.Michelson.Typed (Contract'(..), SomeContract(..), unContractCode)-import Morley.Michelson.Untyped qualified as U+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Typed.Contract (mapContractCodeM) import Morley.Tezos.Address import Morley.Tezos.Address.Alias-import Morley.Tezos.Core (Mutez, Timestamp(..), tz)-import Morley.Tezos.Crypto+import Morley.Tezos.Core (Mutez, tz) import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)-import Morley.Util.CLI (mkCommandParser, outputOption)+import Morley.Util.CLI (mkCLOptionParser, mkCommandParser, outputOption) import Morley.Util.Main (wrapMain) import Morley.Util.Named import REPL -------------------------------------------------------------------------------- Command line options-----------------------------------------------------------------------------+data DryRunOrWrite = DryRun | Write -data CmdLnArgs- = Print ("input" :? FilePath) ("output" :? FilePath) ("singleLine" :! Bool)- | Optimize OptimizeOptions- | Analyze AnalyzeOptions- | TypeCheck TypeCheckOptions- | Run RunOptions- | Originate OriginateOptions- | Transfer TransferOptions- | CreateChest CreateChestOptions- | REPL+mkCommandParser' :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a+mkCommandParser' = flip . mkCommandParser -data OptimizeOptions = OptimizeOptions- { optoContractFile :: Maybe FilePath- , optoOutput :: Maybe FilePath- , optoSingleLine :: Bool- }+argParser :: Opt.Parser (IO ())+argParser = subparser $ mconcat+ [ printSubCmd+ , typecheckSubCmd+ , emulateSubCmd+ , optimizeSubCmd+ , analyzeSubCmd+ , createChestSubCmd+ , replSubCmd+ ] -data AnalyzeOptions = AnalyzeOptions- { aoContractFile :: Maybe FilePath- }+--------------------------------------------------------------------------------+-- Subcommands+-------------------------------------------------------------------------------- -data CreateChestOptions = CreateChestOptions- { ccPayload :: ByteString- , ccTime :: TLTime- }+-- NB: in case this looks mysterious, in IOCmd functions, outer 'do' is+-- Opt.Parser using ApplicativeDo, which then returns an IO action, i.e. inner+-- 'do' is 'IO ()'. -- @lierdakil -data TypeCheckOptions = TypeCheckOptions- { tcoContractFile :: Maybe FilePath- , tcoTcOptions :: TypeCheck.TypeCheckOptions- }+type IOCmd = Opt.Mod Opt.CommandFields (IO ()) -data RunOptions = RunOptions- { roContractFile :: Maybe FilePath- , roDBPath :: FilePath- , roTcOptions :: TypeCheck.TypeCheckOptions- , roStorageValue :: U.Value- , roTxData :: TxData- , roVerbose :: Bool- , roNow :: Maybe Timestamp- , roLevel :: Maybe Natural- , roMinBlockTime :: Maybe Natural- , roMaxSteps :: Word64- , roInitBalance :: Mutez- , roWrite :: Bool- }+typecheckSubCmd :: IOCmd+typecheckSubCmd = mkCommandParser' "typecheck" "Typecheck passed contract." do+ contractFile <- optional contractFileOption+ tcOptions <- typeCheckOptionsOption+ pure do+ morleyContract <- prepareContract contractFile+ -- 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 tcOptions+ $ typeCheckContract morleyContract+ when (TypeCheck.tcVerbose tcOptions) $+ putStrLn $ printSomeContract False contract+ putTextLn "Contract is well-typed" -data OriginateOptions = OriginateOptions- { ooContractFile :: Maybe FilePath- , ooDBPath :: FilePath- , ooTcOptions :: TypeCheck.TypeCheckOptions- , ooOriginator :: ImplicitAddress- , ooAlias :: Maybe ContractAlias- , ooDelegate :: Maybe KeyHash- , ooStorageValue :: U.Value- , ooBalance :: Mutez- , ooVerbose :: Bool- }+printSubCmd :: IOCmd+printSubCmd = mkCommandParser' "print"+ "Parse a Morley contract and print corresponding Michelson \+ \contract that can be parsed by the OCaml reference client: octez-client."+ do+ mInputFile <- optional contractFileOption+ mOutputFile <- outputOption+ forceSingleLine <- onelineOption+ pure do+ contract <- prepareContract mInputFile+ let write = maybe putStrLn Utf8.writeFile mOutputFile+ write $ printUntypedContract forceSingleLine contract -data TransferOptions = TransferOptions- { toDBPath :: FilePath- , toTcOptions :: TypeCheck.TypeCheckOptions- , toDestination :: SomeAddressOrAlias- , toTxData :: TxData- , toNow :: Maybe Timestamp- , toLevel :: Maybe Natural- , toMinBlockTime :: Maybe Natural- , toMaxSteps :: Word64- , toVerbose :: Bool- , toDryRun :: Bool- }+emulateSubCmd :: IOCmd+emulateSubCmd = mkCommandParser' "emulate" "Set of commands to run in an emulated environment." $+ subparser $ mconcat+ [ runSubCmd+ , originateSubCmd+ , transferSubCmd+ , transferTicketSubCmd+ , runViewSubCmd+ ] -argParser :: Opt.Parser CmdLnArgs-argParser = subparser $- printSubCmd <>- typecheckSubCmd <>- emulateSubCmd <>- optimizeSubCmd <>- analyzeSubCmd <>- createChestSubCmd <>- replSubCmd- where- typecheckSubCmd =- mkCommandParser "typecheck"- (TypeCheck <$> typeCheckOptions) $- ("Typecheck passed contract.")+runSubCmd :: IOCmd+runSubCmd = mkCommandParser' "run"+ "Run passed contract. It's originated first and then a transaction is sent to it." do+ txData <- txDataOption+ contract <- contractSimpleOriginationDataOption+ cro <- commonRunOptions Write+ pure do+ michelsonContract <- traverse prepareContract contract+ void $ runContract cro michelsonContract txData - printSubCmd =- mkCommandParser "print"- (Print <$> (#input <:?> optional contractFileOption)- <*> (#output <:?> outputOption)- <*> (#singleLine <:!> onelineOption))- ("Parse a Morley contract and print corresponding Michelson " <>- "contract that can be parsed by the OCaml reference client: `octez-client`.")+runViewSubCmd :: IOCmd+runViewSubCmd = mkCommandParser' "view"+ "Run some view on a contract either supplied directly or identified \+ \by an address. It's originated first if supplied directly." do+ cro <- commonRunOptions Write+ addressOrContract <-+ ContractSpecAddressOrAlias <$> addressOrAliasOption Nothing+ ! #name "contract-addr"+ ! #help "Contract address to call view on."+ <|> ContractSpecOrigination <$> contractSimpleOriginationDataOption+ viewName <- mkCLOptionParser Nothing+ ! #name "name"+ ! #help "View name."+ sender <- someAddressOrAliasOption+ (Just $ SAOAKindSpecified $ AddressResolved genesisAddress)+ ! #name "sender"+ ! #help "Sender address."+ viewArg <- TxUntypedParam <$> valueOption Nothing+ ! #name "arg"+ ! #help "View call argument."+ pure do+ contractSpec <- (traverse . traverse) prepareContract addressOrContract+ void $ runView cro contractSpec viewName sender viewArg - emulateSubCmd =- mkCommandParser "emulate"- (subparser $ runSubCmd- <> originateSubCmd- <> transferSubCmd)- ("Set of commands to run in an emulated environment.")+replSubCmd :: IOCmd+replSubCmd = mkCommandParser' "repl" "Start a Morley REPL." $ pure runRepl - runSubCmd =- mkCommandParser "run"- (Run <$> runOptions) $- "Run passed contract. \- \It's originated first and then a transaction is sent to it."+originateSubCmd :: IOCmd+originateSubCmd = mkCommandParser' "originate" "Originate passed contract. Add it to passed DB." do+ simpleOriginationData <- contractSimpleOriginationDataOption+ dbPath <- dbPathOption+ tcOptions <- typeCheckOptionsOption+ verbose <- verboseFlag+ originator <- addressOption (Just genesisAddress)+ ! #name "originator"+ ! #help "Contract's originator."+ alias <- optional (aliasOption "alias")+ delegate <- optional $ keyHashOption Nothing+ ! #name "delegate"+ ! #help "Contract's optional delegate."+ pure do+ michelsonContract <- traverse prepareContract simpleOriginationData+ addr <-+ originateContract+ ! #dbPath dbPath+ ! #tcOpts tcOptions+ ! #originator originator+ ! paramF #alias alias+ ! paramF #delegate delegate+ ! #csod michelsonContract+ ! #verbose verbose+ putTextLn $ "Originated contract " <> pretty addr - replSubCmd =- mkCommandParser "repl"- (pure REPL)- "Start a Morley REPL."+transferSubCmd :: IOCmd+transferSubCmd = mkCommandParser' "transfer" "Transfer tokens to given address." do+ destination <- someAddressOrAliasOption Nothing+ ! #name "to"+ ! #help "Address or alias of the transfer's destination."+ txData <- txDataOption+ cro <- commonRunOptions DryRun+ pure $ transfer cro destination txData - originateSubCmd =- mkCommandParser "originate"- (Originate <$> originateOptions)- "Originate passed contract. Add it to passed DB."+transferTicketSubCmd :: IOCmd+transferTicketSubCmd = mkCommandParser' "transfer-ticket" "Transfer ticket to given address." do+ destination <- someAddressOrAliasOption Nothing+ ! #name "to"+ ! #help "Address or alias of the transfer's destination."+ tdSenderAddress :: L1Address <- Constrained <$> addressOption (Just genesisAddress)+ ! #name "sender" ! #help "Sender address"+ ticketer <- mkCLOptionParser @Address Nothing+ ! #name "ticketer" ! #help "Ticketer"+ value <- valueOption Nothing+ ! #name "value" ! #help "Ticket value"+ ty <- mkCLOptionParser Nothing+ ! #name "type" ! #help "Ticket argument type"+ tAmount <- mkCLOptionParser @Natural Nothing+ ! #name "amount" ! #help "Amount of tickets"+ tdAmount <- mutezOption (Just minBound)+ ! #name "mutez" ! #help "Mutez amount additionally sent by a transaction. \+ \Note that on network, as of Mumbai, implicit accounts can't send tickets \+ \and mutez in the same operation, however the Morley emulator allows it."+ tdEntrypoint <- entrypointOption+ ! #name "entrypoint" ! #help "Entrypoint to call"+ cro <- commonRunOptions DryRun+ pure $ T.withUType ty \(_ :: T.Notes t) -> do+ tValue <- either throwM pure . typeCheckingWith (croTCOpts cro) $+ typeCheckValue @t value+ T.Dict <- either (throwM . TypeCheck.UnsupportedTypeForScope (demote @t)) pure $+ T.checkScope @(T.ParameterScope t, T.Comparable t)+ let tdParameter = TxTypedParam $ T.VTicket ticketer tValue tAmount+ transfer cro destination TxData{..} - transferSubCmd =- mkCommandParser "transfer"- (Transfer <$> transferOptions)- "Transfer tokens to given address."+optimizeSubCmd :: IOCmd+optimizeSubCmd = mkCommandParser' "optimize" "Optimize the contract." do+ contractFile <- optional contractFileOption+ output <- outputOption+ singleLine <- onelineOption+ maxStageIterations <- mkCLOptionParser (Just $ ocMaxIterations def)+ ! #name "max-stage-iterations"+ ! #help "Maximum number of iterations per optimizer stage. \+ \The default is usually adequate, but you want to try raising it \+ \to see if it affects the result."+ verbose <- verboseFlag+ pure do+ untypedContract <- prepareContract contractFile+ SomeContract checkedContract <-+ either throwM pure . typeCheckingWith laxTcOptions $+ typeCheckContract untypedContract+ let (logs, optimizedContract) =+ mapContractCodeM (optimizeVerboseWithConf conf) checkedContract+ conf = def { ocMaxIterations = maxStageIterations }+ maybe putStrLn Utf8.writeFile output $ printTypedContract singleLine optimizedContract+ when verbose $ hPutStrLn stderr $ pretty @_ @Text $ unlinesF logs - optimizeSubCmd =- mkCommandParser "optimize"- (Optimize <$> optimizeOptions)- "Optimize the contract."+analyzeSubCmd :: IOCmd+analyzeSubCmd = mkCommandParser' "analyze" "Analyze the contract." do+ contractFile <- optional contractFileOption+ pure do+ untypedContract <- prepareContract contractFile+ SomeContract contract <-+ either throwM pure . typeCheckingWith laxTcOptions $+ typeCheckContract untypedContract+ putTextLn $ pretty $ analyze (unContractCode $ cCode contract) - analyzeSubCmd =- mkCommandParser "analyze"- (Analyze <$> analyzeOptions)- "Analyze the contract."+createChestSubCmd :: IOCmd+createChestSubCmd = mkCommandParser' "create_chest" "Create a timelocked chest and key." do+ payload <- payloadOption+ time <- timeOption+ pure do+ (chest, key) <- createChestAndChestKey payload time+ putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)+ putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key) - createChestSubCmd =- mkCommandParser "create_chest"- (CreateChest <$> createChestOptions)- "Create a timelocked chest and key."+--------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------- - verboseFlag :: Opt.Parser Bool- verboseFlag = switch $- short 'v' <>- long "verbose" <>- help "Whether output should be verbose."+verboseFlag :: Opt.Parser Bool+verboseFlag = switch $+ short 'v' <>+ long "verbose" <>+ help "Whether output should be verbose." - writeFlag :: Opt.Parser Bool- writeFlag = switch $- long "write" <>- help "Whether updated DB should be written to DB file."+typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions+typeCheckOptionsOption = do+ tcVerbose <- verboseFlag+ tcStrict <- fmap not . switch $+ long "typecheck-lax" <>+ help "Whether actions permitted in `octez-client run` but forbidden in \+ \e.g. `octez-client originate` should be allowed here."+ return TypeCheck.TypeCheckOptions{..} - dryRunFlag :: Opt.Parser Bool- dryRunFlag = switch $+commonRunOptions :: DryRunOrWrite -> Opt.Parser CommonRunOptions+commonRunOptions defaultDryRun = do+ croNow <- nowOption+ croLevel <- fromMaybe (croLevel def) <$> levelOption+ croMinBlockTime <- fromMaybe (croMinBlockTime def) <$> minBlockTimeOption+ croMaxSteps <- RemainingSteps <$> maxStepsOption+ croDBPath <- dbPathOption+ croTCOpts <- typeCheckOptionsOption+ croVerbose <- verboseFlag+ croDryRun <- case defaultDryRun of+ Write -> fmap not . switch $+ long "write" <>+ help "Write updated DB to the DB file."+ DryRun -> switch $ long "dry-run" <>- help "Do not write updated DB to DB file."-- typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions- typeCheckOptionsOption = do- tcVerbose <- verboseFlag- tcStrict <- fmap not . switch $- long "typecheck-lax" <>- help "Whether actions permitted in `octez-client run` but forbidden in \- \e.g. `octez-client originate` should be allowed here."- return TypeCheck.TypeCheckOptions{..}-- typeCheckOptions :: Opt.Parser TypeCheckOptions- typeCheckOptions = TypeCheckOptions- <$> optional contractFileOption- <*> typeCheckOptionsOption-- defaultBalance :: Mutez- defaultBalance = [tz|4|]-- optimizeOptions :: Opt.Parser OptimizeOptions- optimizeOptions = OptimizeOptions- <$> optional contractFileOption- <*> outputOption- <*> onelineOption-- analyzeOptions :: Opt.Parser AnalyzeOptions- analyzeOptions = AnalyzeOptions <$> optional contractFileOption-- createChestOptions :: Opt.Parser CreateChestOptions- createChestOptions = CreateChestOptions <$> payloadOption <*> timeOption+ help "Do not write updated DB to the DB file."+ pure CommonRunOptions{..} - runOptions :: Opt.Parser RunOptions- runOptions =- RunOptions- <$> optional contractFileOption- <*> dbPathOption- <*> typeCheckOptionsOption- <*> valueOption Nothing (#name :! "storage")- (#help :! "Initial storage of a running contract.")- <*> txDataOption- <*> verboseFlag- <*> nowOption- <*> levelOption- <*> minBlockTimeOption- <*> maxStepsOption- <*> mutezOption (Just defaultBalance)- (#name :! "balance") (#help :! "Initial balance of this contract.")- <*> writeFlag+contractSimpleOriginationDataOption :: Opt.Parser (ContractSimpleOriginationData (Maybe FilePath))+contractSimpleOriginationDataOption = do+ csodStorage <- valueOption Nothing+ ! #name "storage"+ ! #help "Initial storage of the contract."+ csodContract <- optional contractFileOption+ csodBalance <- mutezOption (Just defaultBalance)+ ! #name "balance"+ ! #help "Initial balance of the contract."+ pure ContractSimpleOriginationData{..} - originateOptions :: Opt.Parser OriginateOptions- originateOptions =- OriginateOptions- <$> optional contractFileOption- <*> dbPathOption- <*> typeCheckOptionsOption- <*> addressOption (Just genesisAddress)- (#name :! "originator") (#help :! "Contract's originator.")- <*> optional (aliasOption "alias")- <*> optional- (keyHashOption Nothing- (#name :! "delegate") (#help :! "Contract's optional delegate.")- )- <*> valueOption Nothing- (#name :! "storage") (#help :! "Initial storage of an originating contract.")- <*> mutezOption (Just defaultBalance)- (#name :! "balance") (#help :! "Initial balance of an originating contract.")- <*> verboseFlag+--------------------------------------------------------------------------------+-- Constants+-------------------------------------------------------------------------------- - transferOptions :: Opt.Parser TransferOptions- transferOptions = do- toDBPath <- dbPathOption- toTcOptions <- typeCheckOptionsOption- toDestination <-- someAddressOrAliasOption- Nothing- (#name :! "to")- (#help :! "Address or alias of the transfer's destination.")- toTxData <- txDataOption- toNow <- nowOption- toLevel <- levelOption- toMinBlockTime <- minBlockTimeOption- toMaxSteps <- maxStepsOption- toVerbose <- verboseFlag- toDryRun <- dryRunFlag- pure TransferOptions {..}+defaultBalance :: Mutez+defaultBalance = [tz|4|] -- | Most permitting options, when we don't care much about typechecking. laxTcOptions :: TypeCheck.TypeCheckOptions@@ -286,12 +308,12 @@ , TypeCheck.tcStrict = False } -----------------------------------------------------------------------------+-------------------------------------------------------------------------------- -- Actual main-----------------------------------------------------------------------------+-------------------------------------------------------------------------------- main :: IO ()-main = wrapMain $ run =<< execParser programInfo+main = wrapMain $ join $ execParser programInfo where programInfo = info (helper <*> versionOption <*> argParser) $ mconcat@@ -303,67 +325,6 @@ versionOption = infoOption ("morley-" <> showVersion version) (long "version" <> help "Show version.")-- run :: CmdLnArgs -> IO ()- run 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- checkedContract <-- either throwM pure . typeCheckingWith laxTcOptions $- typeCheckContract untypedContract- let optimizedContract = mapSomeContract optimize checkedContract- let write = maybe putStrLn Utf8.writeFile optoOutput- write $ printSomeContract optoSingleLine optimizedContract- Analyze AnalyzeOptions{..} -> do- untypedContract <- prepareContract aoContractFile- SomeContract contract <-- either throwM pure . typeCheckingWith laxTcOptions $- typeCheckContract untypedContract- putTextLn $ pretty $ analyze (unContractCode $ cCode contract)- TypeCheck TypeCheckOptions{..} -> do- 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- $ typeCheckContract morleyContract- when (TypeCheck.tcVerbose tcoTcOptions) $- putStrLn $ printSomeContract False contract- putTextLn "Contract is well-typed"- Run RunOptions {..} -> do- michelsonContract <- prepareContract roContractFile- void $ runContract roNow roLevel roMinBlockTime roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData- ! #verbose roVerbose- ! #dryRun (not roWrite)- Originate OriginateOptions {..} -> do- michelsonContract <- prepareContract ooContractFile- addr <-- originateContract- ooDBPath- ooTcOptions- ooOriginator- ooAlias- ooDelegate- ooBalance- ooStorageValue- michelsonContract- ! #verbose ooVerbose- putTextLn $ "Originated contract " <> pretty addr- Transfer TransferOptions {..} -> do- transfer toNow toLevel toMinBlockTime toMaxSteps toDBPath toTcOptions toDestination toTxData- ! #verbose toVerbose- ! #dryRun toDryRun- REPL -> runRepl- CreateChest CreateChestOptions {..} -> do- (chest, key) <- createChestAndChestKey ccPayload ccTime- putStrLn $ "Chest: 0x" <> encodeHex (chestBytes chest)- putStrLn $ "Key: 0x" <> encodeHex (chestKeyBytes key)- usageDoc :: Maybe Doc usageDoc = Just $ mconcat
app/REPL.hs view
@@ -31,7 +31,7 @@ import Text.Megaparsec (parse) import Morley.Michelson.Interpret (interpretInstr)-import Morley.Michelson.Macro (ParsedOp, expandList)+import Morley.Michelson.Macro (ParsedOp, expand) import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_) import Morley.Michelson.Parser.Types (MichelsonSource(..)) import Morley.Michelson.Printer (printDoc, printTypedValue)@@ -144,7 +144,6 @@ tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput- tryParseMichelsonValue @'T.TTxRollupL2Address "Michelson Transaction Rollup L2 Address" parseInput tryParseMichelsonValue @'T.TString "Michelson String" parseInput tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput@@ -172,10 +171,6 @@ Right p -> do printResult "KeyHash" $ formatHash p Left _ -> pass- case parseHash @'HashKindL2PublicKey parseInput of- Right p -> do- printResult "KeyHash" $ formatHash p- Left _ -> pass case Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 parseInput) of Just p -> do printResult "Base58 Encoded Bytes" $ "0x" <> (encodeHex p)@@ -192,7 +187,7 @@ Left err -> printErr err Right [] -> pass Right parsedOps -> do- let expandedOps = expandList parsedOps+ let expandedOps = expand <$> parsedOps lift get >>= \case SomeStack {..} -> case castSing stTypes of Just hstInp -> case typeCheckingWith tcOptions . runTypeCheckIsolated $
morley.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley-version: 1.19.0+version: 1.19.1 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, 2021-2022 Oxhead Alpha+copyright: 2018 camlCase, 2019-2021 Tocqueville Group, 2021-2023 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple@@ -45,12 +45,15 @@ Morley.Michelson.Doc Morley.Michelson.ErrorPos Morley.Michelson.FailPattern+ Morley.Michelson.Internal.ViewName+ Morley.Michelson.Internal.ViewsSet Morley.Michelson.Interpret Morley.Michelson.Interpret.Pack Morley.Michelson.Interpret.Unpack Morley.Michelson.Interpret.Utils Morley.Michelson.Macro Morley.Michelson.Optimizer+ Morley.Michelson.Optimizer.Internal.Proofs Morley.Michelson.Parser Morley.Michelson.Parser.Annotations Morley.Michelson.Parser.Common@@ -114,6 +117,8 @@ Morley.Michelson.Typed.Haskell.ValidateDescription Morley.Michelson.Typed.Haskell.Value Morley.Michelson.Typed.Instr+ Morley.Michelson.Typed.Instr.Constraints+ Morley.Michelson.Typed.Instr.Internal.Proofs Morley.Michelson.Typed.Operation Morley.Michelson.Typed.Polymorphic Morley.Michelson.Typed.Scope@@ -138,6 +143,7 @@ Morley.Tezos.Address.Kinds Morley.Tezos.Core Morley.Tezos.Crypto+ Morley.Tezos.Crypto.BLS Morley.Tezos.Crypto.BLS12381 Morley.Tezos.Crypto.Ed25519 Morley.Tezos.Crypto.Hash@@ -171,6 +177,7 @@ Morley.Util.Sing Morley.Util.SizedList Morley.Util.SizedList.Types+ Morley.Util.StubbedProof Morley.Util.Text Morley.Util.TH Morley.Util.Type@@ -261,6 +268,7 @@ , generic-deriving , gitrev , hex-text+ , hsblst , lens , megaparsec >=7.0.0 , memory@@ -360,12 +368,14 @@ , base-noprelude >=4.7 && <5 , base58-bytestring , bytestring+ , data-default , fmt , haskeline , hex-text , megaparsec >=7.0.0 , morley , morley-prelude+ , named , optparse-applicative , singletons , text
src/Morley/AsRPC.hs view
@@ -9,9 +9,6 @@ , deriveRPCWithOptions , DeriveRPCOptions(..) , deriveRPC- , deriveRPCWithStrategy- , deriveManyRPC- , deriveManyRPCWithStrategy -- * Conversions , valueAsRPC , replaceBigMapIds@@ -52,7 +49,7 @@ HasNoContract, HasNoNestedBigMaps, HasNoOp, IsoValue, Notes(..), OpPresence(..), Operation, SingI(sing), SingT(..), StorageScope, T(..), ToT, Value, Value'(..), WellTyped, checkContractTypePresence, checkOpPresence, withDict)-import Morley.Tezos.Address (Address, TxRollupL2Address)+import Morley.Tezos.Address (Address) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto import Morley.Util.CustomGeneric@@ -143,7 +140,6 @@ TAsRPC 'TBls12381G2 = 'TBls12381G2 TAsRPC 'TChest = 'TChest TAsRPC 'TChestKey = 'TChestKey- TAsRPC 'TTxRollupL2Address = 'TTxRollupL2Address TAsRPC ('TSaplingState n) = ('TSaplingState n) TAsRPC ('TSaplingTransaction n) = ('TSaplingTransaction n) @@ -268,8 +264,6 @@ type AsRPC Chest = Chest instance HasRPCRepr ChestKey where type AsRPC ChestKey = ChestKey-instance HasRPCRepr TxRollupL2Address where- type AsRPC TxRollupL2Address = TxRollupL2Address ---------------------------------------------------------------------------- -- Derive RPC repr@@ -343,12 +337,28 @@ @HasAnnotation@ and its methods must be in scope. +Void types will generate a type synonym instead, e.g.++> data MyVoidType+> deriving stock Generic+> deriving anyclass IsoValue++will produce++> instance HasRPCRepr MyVoidType where+> type AsRPC MyVoidType = MyVoidTypeRPC+> type MyVoidTypeRPC = MyVoidType+ When 'droRecursive' is @True@, recursively enumerate @data@, @newtype@ and @type@ declarations, and derive an RPC representation for each type that doesn't-yet have one.+yet have one. This will however silently skip over void types that do not have+an 'IsoValue' instance, which is usually what you want, but be mindful of this. -You can also pass in a list of types for which you _don't_ want-an RPC representation to be derived in 'droRecursiveSkipTypes'.+You can also pass in a list of types for which you _don't_ want an RPC+representation to be derived in 'droRecursiveSkipTypes'. You may need this if+you're using non-void types that don't have an 'IsoValue' instance as phantom+types somewhere. The algorithm isn't smart enough to figure out those don't need+RPC representation and will try to derive it anyway. In this example, this 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@@ -368,29 +378,7 @@ | otherwise = do typeName <- lookupTypeNameOrFail typeStr whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."- deriveRPCWithStrategy' typeName opts---- | Same as 'deriveRPCWithOptions' with 'droRecursive' set to @True@ and--- 'droHasAnnotation' set to @False@. Accepts 'droRecursiveSkipTypes' as second--- argument.-deriveManyRPC :: String -> [String] -> Q [Dec]-deriveManyRPC typeStr droRecursiveSkipTypes = deriveRPCWithOptions typeStr DeriveRPCOptions- { droRecursive = True- , droHasAnnotation = False- , droStrategy = haskellBalanced- , droRecursiveSkipTypes- }-{-# DEPRECATED deriveManyRPC "Use deriveRPCWithOptions instead" #-}---- | Same as 'deriveManyRPC', but uses a custom strategy for deriving a 'Generic' instance.-deriveManyRPCWithStrategy :: String -> [String] -> GenericStrategy -> Q [Dec]-deriveManyRPCWithStrategy typeStr skipTypes strategy = deriveRPCWithOptions typeStr DeriveRPCOptions- { droRecursive = True- , droHasAnnotation = False- , droRecursiveSkipTypes=skipTypes- , droStrategy = strategy- }-{-# DEPRECATED deriveManyRPCWithStrategy "Use deriveRPCWithOptions instead" #-}+ deriveRPCWithStrategy' typeName False opts deriveManyRPCWithStrategy' :: String -> DeriveRPCOptions -> Q [Dec] deriveManyRPCWithStrategy' typeStr opts@DeriveRPCOptions{droRecursiveSkipTypes} = do@@ -399,7 +387,7 @@ 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 opts+ deriveRPCWithStrategy' name (name /= typeName) opts where -- Recursively enumerate @data@, @newtype@ and @type@ declarations,@@ -408,16 +396,11 @@ -- 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]+ fmap fst <$> flip reifyManyTyCons [typeName] \(name, dec) ->+ ifM (hasRPCInstance name)+ do pure (False, []) -- exclude, don't recurse further+ do (, decConcreteNames dec) . not <$> isTypeAlias name+ -- exclude type aliases, recurse further hasRPCInstance :: Name -> Q Bool hasRPCInstance typeName = do@@ -444,59 +427,62 @@ 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 name gs = deriveRPCWithOptions name DeriveRPCOptions- { droHasAnnotation = False- , droRecursive = False- , droRecursiveSkipTypes = []- , droStrategy = gs- }-{-# DEPRECATED deriveRPCWithStrategy "Use deriveRPCWithOptions instead" #-}--deriveRPCWithStrategy' :: Name -> DeriveRPCOptions -> Q [Dec]-deriveRPCWithStrategy' typeName DeriveRPCOptions{..} = do+-- skipVoids is set to True when doing deriveManyRPC recursively, i.e. for types+-- not explicitly requested by the caller.+deriveRPCWithStrategy' :: Name -> Bool -> DeriveRPCOptions -> Q [Dec]+deriveRPCWithStrategy' typeName skipVoids DeriveRPCOptions{..} = do (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName - -- TODO [#722]: 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+ let typeNameRPC = convertName typeName 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 tyVars- typeDecOfRPC <- mkTypeDeclaration typeName decCxt typeNameRPC tyVars mKind constructorsRPC+ if null constructors+ then ifM ((skipVoids &&) . null <$> reifyInstances ''IsoValue [derivedType])+ -- if a void type doesn't have an IsoValue instance, it's likely used as a+ -- typelevel tag. Skip it. Otherwise, derive a trivial 'HasRPCRepr'+ -- instance.+ do pure []+ do sequence+ [ mkAsRPCInstance [] derivedType derivedTypeRPC+ , pure $ TySynD typeNameRPC [] $ ConT typeName+ ]+ else do+ -- TODO [#722]: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`+ -- Print user-friendly error msg if it doesn't.+ constructorsRPC <- traverse convertConstructor constructors+ fieldTypes <- getFieldTypes constructors+ fieldTypesRPC <- getFieldTypes constructorsRPC - -- Slightly modify the deriving strategy so that the field/constructor- -- reordering function from original strategy acts on input field names in- -- RPC type after stripping RPC suffix. Fix for #811- let- gs' = mangleGenericStrategyFields dropRPCSuffix $- mangleGenericStrategyConstructors dropRPCSuffix droStrategy+ -- 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 tyVars+ 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'- , annotationInstance fieldTypes derivedType derivedTypeRPC- ]+ -- Slightly modify the deriving strategy so that the field/constructor+ -- reordering function from original strategy acts on input field names in+ -- RPC type after stripping RPC suffix. Fix for #811+ let+ gs' = mangleGenericStrategyFields dropRPCSuffix $+ mangleGenericStrategyConstructors dropRPCSuffix droStrategy + mconcat <$> sequence+ [ pure . one $ typeDecOfRPC+ , one <$> mkAsRPCInstance fieldTypes derivedType derivedTypeRPC+ , mkIsoValueInstance fieldTypesRPC derivedTypeRPC+ , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs'+ , annotationInstance fieldTypes derivedType derivedTypeRPC+ ]+ where -- Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@. convertFieldType :: Type -> Type@@ -736,7 +722,6 @@ VBls12381Fr {} -> v VBls12381G1 {} -> v VBls12381G2 {} -> v- VTxRollupL2Address {} -> v -- | Replaces all bigmap IDs with their corresponding bigmap values. -- This is the inverse of `valueAsRPC`.@@ -755,7 +740,6 @@ (STChainId {}, _) -> pure v (STChest {}, _) -> pure v (STChestKey {}, _) -> pure v- (STTxRollupL2Address {}, _) -> pure v (STOption sMaybe, VOption vMaybe) -> withSingI sMaybe $ VOption <$> traverse (go sMaybe) vMaybe@@ -828,7 +812,6 @@ NTBls12381G1 {} -> notes NTBls12381G2 {} -> notes NTNever {} -> notes- NTTxRollupL2Address {} -> notes NTSaplingState {} -> notes NTSaplingTransaction {} -> notes @@ -878,7 +861,6 @@ STTimestamp {} -> Dict STAddress {} -> Dict STNever {} -> Dict- STTxRollupL2Address {} -> Dict STSaplingState _ -> Dict STSaplingTransaction _ -> Dict @@ -921,7 +903,6 @@ STChest {} -> Dict STChestKey {} -> Dict STNever {} -> Dict- STTxRollupL2Address {} -> Dict STSaplingState _ -> Dict STSaplingTransaction _ -> Dict @@ -965,7 +946,6 @@ STBls12381G2 {} -> Dict STTimestamp {} -> Dict STAddress {} -> Dict- STTxRollupL2Address {} -> Dict STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict@@ -1008,7 +988,6 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict- STTxRollupL2Address {} -> Dict -- | A proof that @AsRPC (Value t)@ does not contain big_maps. rpcHasNoNestedBigMapsEvi@@ -1054,7 +1033,6 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict- STTxRollupL2Address {} -> Dict -- | A proof that if @t@ does not contain any contract values, then neither does @TAsRPC t@. rpcHasNoContractEvi@@ -1103,7 +1081,6 @@ STNever {} -> Dict STSaplingState {} -> Dict STSaplingTransaction {} -> Dict- STTxRollupL2Address {} -> 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)
src/Morley/CLI.hs view
@@ -259,3 +259,12 @@ P.parseExpandValue MSCli . toText getMetavar = "MICHELSON VALUE"++-- This instance uses parser which is not in the place where 'U.Ty'+-- is defined, hence it is orphan.+instance HasCLReader U.Ty where+ getReader = eitherReader+ $ first (mappend "Failed to parse type: " . displayException)+ . P.parseType MSCli+ . toText+ getMetavar = "MICHELSON TYPE"
src/Morley/Micheline/Binary/Internal.hs view
@@ -3,24 +3,11 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA -- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems +{-# OPTIONS_HADDOCK not-home #-}+ -- | Defines binary encoding primitives which mimic Tezos' binary encoding. module Morley.Micheline.Binary.Internal- ( DynamicSize(..)-- -- * Encode- , buildWord8- , buildText- , buildInteger- , buildNatural- , buildDynamic- , buildByteString-- -- * Decode- , getText- , getNatural- , getInteger- , getDynamic- , getByteString+ ( module Morley.Micheline.Binary.Internal ) where import Control.Exception (assert)
src/Morley/Micheline/Class.hs view
@@ -116,7 +116,6 @@ Untyped.TAddress -> expressionPrim' "address" [] [] Untyped.TChest -> expressionPrim' "chest" [] [] Untyped.TChestKey -> expressionPrim' "chest_key" [] []- Untyped.TTxRollupL2Address -> expressionPrim' "tx_rollup_l2_address" [] [] Untyped.TNever -> expressionPrim' "never" [] [] Untyped.TSaplingState n -> expressionPrim' "sapling_state" [integralToExpr n] [] Untyped.TSaplingTransaction n -> expressionPrim' "sapling_transaction" [integralToExpr n] []@@ -259,6 +258,8 @@ LE va -> expressionPrim' "LE" [] $ mkAnns [] [] [va] GE va -> expressionPrim' "GE" [] $ mkAnns [] [] [va] INT va -> expressionPrim' "INT" [] $ mkAnns [] [] [va]+ NAT va -> expressionPrim' "NAT" [] $ mkAnns [] [] [va]+ BYTES va -> expressionPrim' "BYTES" [] $ mkAnns [] [] [va] VIEW va n t -> expressionPrim' "VIEW" [toExpression n, toExpression t] $ mkAnns [] [] [va] SELF va fa -> expressionPrim' "SELF" [] $ mkAnns [] [fa] [va]@@ -665,6 +666,8 @@ ExpPrim' _ "LE" [] anns -> mkInstrWithVarAnn LE anns ExpPrim' _ "GE" [] anns -> mkInstrWithVarAnn GE anns ExpPrim' _ "INT" [] anns -> mkInstrWithVarAnn INT anns+ ExpPrim' _ "NAT" [] anns -> mkInstrWithVarAnn NAT anns+ ExpPrim' _ "BYTES" [] anns -> mkInstrWithVarAnn BYTES anns ExpPrim' _ "VIEW" [name, t] _ -> do let va = firstAnn @VarTag annSet name' <- fromExp @x @ViewName name@@ -923,7 +926,8 @@ ExpPrim' _ "address" [] [] -> pure Untyped.TAddress ExpPrim' _ "chest" [] [] -> pure Untyped.TChest ExpPrim' _ "chest_key" [] [] -> pure Untyped.TChestKey- ExpPrim' _ "tx_rollup_l2_address" [] [] -> pure Untyped.TTxRollupL2Address+ ExpPrim' _ "tx_rollup_l2_address" [] [] ->+ Left $ FromExpError e "Transaction rollups are not supported" ExpPrim' _ "never" [] [] -> pure Untyped.TNever ExpPrim' _ "sapling_state" [n] [] -> do n' <- integralFromExpr n
src/Morley/Micheline/Expression.hs view
@@ -132,7 +132,8 @@ "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_deprecated", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket", "TICKET_DEPRECATED", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST",- "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction", "EMIT", "Lambda_rec", "LAMBDA_REC", "TICKET"+ "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction", "EMIT",+ "Lambda_rec", "LAMBDA_REC", "TICKET", "BYTES", "NAT" ] -- | Type for Micheline Expression with extension points.
+ src/Morley/Michelson/Internal/ViewName.hs view
@@ -0,0 +1,94 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | Michelson view name.+module Morley.Michelson.Internal.ViewName+ ( module Morley.Michelson.Internal.ViewName+ ) where++import Control.Monad.Except (throwError)+import Data.Aeson (FromJSONKey(..), ToJSONKey(..))+import Data.Aeson.TH (deriveJSON)+import Data.Aeson.Types qualified as AesonTypes+import Data.Data (Data)+import Data.Text qualified as Text+import Fmt (Buildable(..), pretty, (+|), (|+))+import Text.PrettyPrint.Leijen.Text (Doc, dquotes, textStrict)++import Morley.Michelson.Printer.Util+import Morley.Michelson.Text+import Morley.Util.Aeson+import Morley.Util.CLI++-- | Name of the view.+--+-- 1. It must not exceed 31 chars length;+-- 2. Must use [a-zA-Z0-9_.%@] charset.+newtype ViewName = UnsafeViewName { unViewName :: Text }+ deriving stock (Show, Eq, Ord, Data, Generic)+ deriving newtype (Buildable, NFData)++pattern ViewName :: Text -> ViewName+pattern ViewName name <- UnsafeViewName name+{-# COMPLETE ViewName #-}++deriveJSON morleyAesonOptions ''ViewName++instance HasCLReader ViewName where+ getReader = eitherReader (first pretty . mkViewName . toText)+ getMetavar = "VIEW NAME"++instance ToJSONKey ViewName where+ toJSONKey = AesonTypes.toJSONKeyText unViewName++instance FromJSONKey ViewName where+ fromJSONKey = AesonTypes.FromJSONKeyTextParser $ either (fail . pretty) pure . mkViewName++-- | Whether the given character is valid for a view.+isValidViewNameChar :: Char -> Bool+isValidViewNameChar c = or+ [ 'A' <= c && c <= 'Z'+ , 'a' <= c && c <= 'z'+ , '0' <= c && c <= '9'+ , c `elem` ['_', '.', '%', '@']+ ]++-- | Maximum allowed name length for a view.+viewNameMaxLength :: Int+viewNameMaxLength = 31++data BadViewNameError+ = BadViewTooLong Int+ | BadViewIllegalChars Text+ deriving stock (Show, Eq, Ord, Data, Generic)+ deriving anyclass (NFData)++instance Buildable BadViewNameError where+ build = \case+ BadViewTooLong l ->+ "Bad view name length of " +| l |+ " characters, must not exceed \+ \" +| viewNameMaxLength |+ " characters length"+ BadViewIllegalChars txt ->+ "Invalid characters in the view \"" +| txt |+ ", allowed characters set \+ \is [a-zA-Z0-9_.%@]"++-- | Construct t'ViewName' performing all the checks.+mkViewName :: Text -> Either BadViewNameError ViewName+mkViewName txt = do+ unless (length txt <= viewNameMaxLength) $+ throwError (BadViewTooLong $ length txt)+ unless (Text.all isValidViewNameChar txt) $+ throwError (BadViewIllegalChars txt)+ return (UnsafeViewName txt)++renderViewName :: ViewName -> Doc+renderViewName = dquotes . textStrict . unViewName++instance RenderDoc ViewName where+ renderDoc _ = renderViewName++-- | Valid view names form a subset of valid Michelson texts.+viewNameToMText :: ViewName -> MText+viewNameToMText = unsafe . mkMText . unViewName
+ src/Morley/Michelson/Internal/ViewsSet.hs view
@@ -0,0 +1,70 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | Internal helper types and functions for manipulating view sets+module Morley.Michelson.Internal.ViewsSet+ ( module Morley.Michelson.Internal.ViewsSet+ ) where++import Control.Monad.Except (throwError)+import Data.Aeson (FromJSON, ToJSON)+import Data.Coerce (coerce)+import Data.Default (Default(..))+import Data.List.NonEmpty qualified as NE (group)+import Data.Map qualified as Map+import Fmt (Buildable(..), (+|), (|+))++import Morley.Michelson.Internal.ViewName++-- | Type for intermediate coercions between typed and untyped view sets.+-- Intended as an internal helper.+newtype ViewsSetF a = ViewsSetF { unViewsSetF :: Map ViewName a }+ deriving newtype (FromJSON, ToJSON, Default, NFData, Container, ToPairs)+ deriving stock (Eq, Show, Functor)++-- | Errors possible when constructing @ViewsSet@.+data ViewsSetError+ = DuplicatedViewName ViewName+ deriving stock (Show, Eq)++instance Buildable ViewsSetError where+ build = \case+ DuplicatedViewName name -> "Duplicated view name '" +| name |+ "'"++-- | Convenience function to construct 'ViewsSetF'.+mkViewsSet :: (a -> ViewName) -> [a] -> Either ViewsSetError (ViewsSetF a)+mkViewsSet viewName views = do+ ensureNoDuplicates $ viewName <$> views+ pure $ ViewsSetF $ fromList $ views <&> \v -> (viewName v, v)++-- | No views.+emptyViewsSet :: ViewsSetF a+emptyViewsSet = def++-- | Add a view to set.+addViewToSet+ :: (a -> ViewName)+ -> a+ -> ViewsSetF a+ -> Either ViewsSetError (ViewsSetF a)+addViewToSet name v views = do+ let viewName = name v+ when (viewName `Map.member` unViewsSetF views) $+ throwError $ DuplicatedViewName viewName+ pure $ coerce (Map.insert viewName v) views++-- | Find a view in the set.+lookupView :: ViewName -> ViewsSetF a -> Maybe a+lookupView name = Map.lookup name . unViewsSetF++-- | Get all taken names in views set.+viewsSetNames :: ViewsSetF a -> Set ViewName+viewsSetNames = Map.keysSet . unViewsSetF++ensureNoDuplicates :: [ViewName] -> Either ViewsSetError ()+ensureNoDuplicates names =+ forM_ (NE.group $ sort names) \case+ name :| _ : _ -> throwError $ DuplicatedViewName name+ _ :| _ -> pass
src/Morley/Michelson/Interpret.hs view
@@ -4,7 +4,8 @@ -- | Module, containing function to interpret Michelson -- instructions against given context and input stack. module Morley.Michelson.Interpret- ( ContractEnv (..)+ ( ContractEnv+ , ContractEnv' (..) , InterpreterState (..) , MichelsonFailed (..) , MichelsonFailureWithStack(..)@@ -17,12 +18,16 @@ , interpret , interpretInstr , interpretInstrAnnotated+ , InterpretReturn , ContractReturn+ , RunEvalOpReturn+ , ResultStateLogs(..) , mkInitStack- , fromFinalStack , InterpretError (..)- , InterpretResult (..)+ , InterpretResult+ , ContractResult+ , extractValOps , EvalM , InterpreterStateMonad (..) , StkEl (..)@@ -31,11 +36,20 @@ , runInstrNoGas , runUnpack + -- * Views+ , ViewLookupError (..)+ , interpretView+ , getViewByName+ , getViewByNameAndType+ -- * Internals , initInterpreterState- , handleContractReturn+ , handleReturn+ , runEvalOp , runInstrImpl , assignBigMapIds+ , interpretView'+ , EvalOp (..) -- * Prisms , _MorleyLogs@@ -44,12 +58,13 @@ import Prelude hiding (EQ, GT, LT) import Control.Lens (makeLensesFor, makePrisms, traverseOf, (<<+=))-import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Except (MonadError, liftEither, throwError) import Control.Monad.RWS.Strict (RWS, RWST, runRWS) import Control.Monad.Writer (MonadWriter, WriterT, tell) import Data.Default (Default(..)) import Data.Map qualified as Map import Data.Set qualified as Set+import Data.Singletons (demote) import Data.Singletons.Decide (decideEquality) import Data.Vinyl (Rec(..), (<+>)) import Data.Vinyl.Recursive (rmap)@@ -62,7 +77,7 @@ import Morley.Michelson.Runtime.GState import Morley.Michelson.TypeCheck (eqType) import Morley.Michelson.Typed hiding (Branch(..))-import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Typed.Instr.Constraints import Morley.Michelson.Typed.Operation (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash) import Morley.Michelson.Untyped (unAnnotation)@@ -73,10 +88,10 @@ (KeyHash, OpeningResult(..), blake2b, checkSignature, hashKey, keccak, mkTLTime, openChest, sha256, sha3, sha512) import Morley.Tezos.Crypto.BLS12381 (checkPairing)+import Morley.Util.MismatchError import Morley.Util.Peano (LongerThan, Peano) import Morley.Util.PeanoNatural (PeanoNatural(..)) import Morley.Util.Sing (eqParamSing)-import Morley.Util.Type import Morley.Util.Typeable -- | Morley logs appearing as interpreter result.@@ -130,15 +145,20 @@ ] ''StkEl --- | Environment for contract execution.-data ContractEnv = ContractEnv+type ContractEnv :: Type+type ContractEnv = ContractEnv' EvalOp++-- | Environment for contract execution. Parametrized by the execution monad,+-- i.e. 'EvalOp' by default, but downstream consumers may define their own if+-- using low-level runners.+data ContractEnv' m = ContractEnv { ceNow :: Timestamp -- ^ Timestamp returned by the 'NOW' instruction. , ceMaxSteps :: RemainingSteps -- ^ Number of steps after which execution unconditionally terminates. , ceBalance :: Mutez -- ^ Current amount of mutez of the current contract.- , ceContracts :: Map ContractAddress ContractState+ , ceContracts :: ContractAddress -> m (Maybe ContractState) -- ^ Information stored about the existing contracts. , ceSelf :: ContractAddress -- ^ Address of the interpreted contract.@@ -163,12 +183,16 @@ -- ^ Current source position information , ceMinBlockTime :: Natural -- ^ Minimum time between blocks+ , ceMetaWrapper :: forall i o. Instr i o -> Instr i o+ -- ^ Saves outer wrapping 'Meta' and 'WithLoc' while traversing the tree,+ -- used internally when reiterating on 'LOOP' and other similar instructions.+ -- If unsure, initialize it with 'id'. } -- | Errors that can be thrown by the interpreter. The @ext@ type variable -- allow the downstreams consumer to add additional exceptions. data MichelsonFailed ext where- MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed ext+ MichelsonFailedWith :: (SingI t, ConstantScope t) => Value t -> MichelsonFailed ext -- ^ Represents @[FAILED]@ state of a Michelson program. Contains -- value that was on top of the stack when @FAILWITH@ was called. MichelsonArithError@@ -217,89 +241,96 @@ instance Buildable ext => Buildable (MichelsonFailureWithStack ext) where build (MichelsonFailureWithStack err loc) = build err <> " at " <> build loc -newtype InterpretError ext = InterpretError (MichelsonFailureWithStack ext, MorleyLogs)- deriving stock (Generic)+data InterpretError ext = InterpretError+ { ieLogs :: MorleyLogs+ , ieFailure :: MichelsonFailureWithStack ext+ } deriving stock (Generic) deriving stock instance Show ext => Show (InterpretError ext) instance Buildable ext => Buildable (InterpretError ext) where- build (InterpretError (mf, _)) = prettyLn mf+ build InterpretError{..} = prettyLn ieFailure -data InterpretResult where- InterpretResult- :: ( StorageScope st )- => { iurOps :: [Operation]- , iurNewStorage :: T.Value st- , iurNewState :: InterpreterState- , iurMorleyLogs :: MorleyLogs- }- -> InterpretResult+data ResultStateLogs res = ResultStateLogs+ { rslResult :: res+ , rslState :: InterpreterState+ , rslLogs :: MorleyLogs+ } deriving stock (Functor, Foldable, Traversable, Show, Generic)+ deriving anyclass NFData -deriving stock instance Show InterpretResult+-- | Pure result of an interpretation, i.e. return value, final interpreter+-- state and execution logs.+type InterpretResult ty = ResultStateLogs (Value ty) -constructIR ::- (StorageScope st) =>- (([Operation], Value' Instr st), InterpreterState, MorleyLogs) ->- InterpretResult-constructIR ((ops, val), st, logs) =- InterpretResult- { iurOps = ops- , iurNewStorage = val- , iurNewState = st- , iurMorleyLogs = logs- }+-- | Pure result of contract interpretation. A specialized version of+-- 'InterpretResult'.+type ContractResult ty = InterpretResult (ContractOut1 ty) -type ContractReturn st =- (Either (MichelsonFailureWithStack Void) ([Operation], T.Value st), (InterpreterState, MorleyLogs))+-- | Result of 'runEvalOp'. Essentially, return value (possibly failing), state+-- and logs.+type RunEvalOpReturn a = ResultStateLogs (Either (MichelsonFailureWithStack Void) a) -handleContractReturn- :: (StorageScope st)- => ContractReturn st -> Either (InterpretError Void) InterpretResult-handleContractReturn (ei, (s, l)) =- bimap (InterpretError . (, l)) (constructIR . (, s, l)) ei+-- | Result of 'interpretView'. A version of 'RunEvalOpReturn' specialized to 'Value'.+type InterpretReturn ty = RunEvalOpReturn (Value ty) +-- | Result of 'interpret'. A version of 'InterpretReturn' specialized to 'ContractOut1'.+type ContractReturn st = InterpretReturn (ContractOut1 st)++-- | On failure, attach logs to failure, but throw away the final state.+handleReturn+ :: InterpretReturn res+ -> Either (InterpretError Void) (ResultStateLogs (Value res))+handleReturn rsl@ResultStateLogs{..} = first (InterpretError rslLogs) . sequence $ rsl++-- | Reset 'ceMetaWrapper` after it is used with an instr.+withMetaWrapper :: forall ext m. EvalM' ext m => InstrRunner m -> InstrRunner m+withMetaWrapper runner instr s = do+ ContractEnv{ceMetaWrapper} <- ask+ local (\env -> env {ceMetaWrapper = id}) $+ runner (ceMetaWrapper instr) s++-- | Extract list of operations from 'ContractOut1' 'Value'.+extractValOps :: Value (ContractOut1 st) -> ([Operation], Value st)+extractValOps (VPair x) = first fromVal x+ -- | Helper function to convert a record of @Value@ to @StkEl@. These will be -- created with @starNotes@.-mapToStkEl :: Rec T.Value inp -> Rec StkEl inp+mapToStkEl :: Rec Value inp -> Rec StkEl inp mapToStkEl = rmap StkEl -- | Helper function to convert a record of @StkEl@ to @Value@. Any present -- notes will be discarded.-mapToValue :: Rec StkEl inp -> Rec T.Value inp+mapToValue :: Rec StkEl inp -> Rec Value inp mapToValue = rmap seValue interpret' :: forall cp st arg. Contract cp st -> EntrypointCallT cp arg- -> T.Value arg- -> T.Value st+ -> Value arg+ -> Value st -> ContractEnv -> InterpreterState -> ContractReturn st-interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $+interpret' Contract{..} epc param initSt env ist = (fmap . fmap) (\(StkEl val :& RNil) -> val) $ runEvalOp (runInstr (unContractCode cCode) $ mkInitStack (liftCallArg epc param) initSt) env ist mkInitStack- :: T.Value param- -> T.Value st+ :: Value param+ -> Value st -> Rec StkEl (ContractInp param st) mkInitStack param st = StkEl- (T.VPair (param, st))+ (VPair (param, st)) :& RNil -fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)-fromFinalStack (StkEl (T.VPair (T.VList ops, st)) :& RNil) =- (map (\(T.VOp op) -> op) ops, st)- interpret :: Contract cp st -> EntrypointCallT cp arg- -> T.Value arg- -> T.Value st+ -> Value arg+ -> Value st -> GlobalCounter -> BigMapCounter -> ContractEnv@@ -318,8 +349,8 @@ interpretInstr :: ContractEnv -> Instr inp out- -> Rec T.Value inp- -> Either (MichelsonFailureWithStack Void) (Rec T.Value out)+ -> Rec Value inp+ -> Either (MichelsonFailureWithStack Void) (Rec Value out) interpretInstr = fmap mapToValue ... interpretInstrAnnotated -- | Interpret an instruction in vacuum, putting no extra constraints on@@ -329,10 +360,10 @@ interpretInstrAnnotated :: ContractEnv -> Instr inp out- -> Rec T.Value inp+ -> Rec Value inp -> Either (MichelsonFailureWithStack Void) (Rec StkEl out) interpretInstrAnnotated env instr inpSt =- fst $+ rslResult $ runEvalOp (runInstr instr $ mapToStkEl inpSt) env@@ -343,20 +374,34 @@ } data SomeItStack where- SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack+ SomeItStack :: ExtInstr inp -> Rec StkEl inp -> SomeItStack -type EvalOp =- ExceptT (MichelsonFailureWithStack Void) $- RWS ContractEnv MorleyLogsBuilder InterpreterState+-- | The main interpreter monad. Downstream consumers which use 'runInstrImpl'+-- directly may define their own monad similar to this one.+--+-- This is a newtype and not a type synonym due to the reader environment, i.e.+-- t'ContractEnv', being parameterized by this monad.+newtype EvalOp a = EvalOp+ (ExceptT (MichelsonFailureWithStack Void) (RWS ContractEnv MorleyLogsBuilder InterpreterState) a)+ deriving newtype+ ( MonadError (MichelsonFailureWithStack Void)+ , MonadState InterpreterState+ , InterpreterStateMonad+ , MonadWriter MorleyLogsBuilder+ , MonadReader ContractEnv+ , Monad+ , Applicative+ , Functor+ ) runEvalOp :: EvalOp a -> ContractEnv -> InterpreterState- -> (Either (MichelsonFailureWithStack Void) a, (InterpreterState, MorleyLogs))-runEvalOp act env initSt =- let (res, is, logs) = runRWS (runExceptT act) env initSt- in (res, (is, buildMorleyLogs logs))+ -> RunEvalOpReturn a+runEvalOp (EvalOp act) env initSt =+ let (rslResult, rslState, buildMorleyLogs -> rslLogs) = runRWS (runExceptT act) env initSt+ in ResultStateLogs{..} class Monad m => InterpreterStateMonad m where getInterpreterState :: m InterpreterState@@ -392,7 +437,7 @@ stateInterpreterState = lift . stateInterpreterState type EvalM' ext m =- ( MonadReader ContractEnv m+ ( MonadReader (ContractEnv' m) m , InterpreterStateMonad m , MonadWriter MorleyLogsBuilder m , MonadError (MichelsonFailureWithStack ext) m@@ -410,7 +455,7 @@ throwMichelson mf = asks ceErrorSrcPos >>= throwError . MichelsonFailureWithStack mf -- | Function to change amount of remaining steps stored in State monad.-runInstr :: EvalM m => InstrRunner m+runInstr :: EvalM' ext m => InstrRunner m runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r runInstr i@(Meta _ _i1) r = runInstrImpl runInstr i r@@ -434,12 +479,16 @@ -- may use other type here. runInstrImpl :: forall ext m. EvalM' ext m => InstrRunner m -> InstrRunner m runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'-runInstrImpl runner (WithLoc ics i) r = local (\env -> env{ceErrorSrcPos = ics}) $ runner i r-runInstrImpl runner (Meta _ i) r = runner i r-runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do- let (inp, end) = rsplit @_ @_ @s r- out <- runInstrImpl runner i inp- return (out <+> end)+runInstrImpl runner (WithLoc ics i) r = do+ -- Add wrapper which will be used later on in loop-like instr.+ let updateEnv env@ContractEnv{..}+ = env { ceErrorSrcPos = ics, ceMetaWrapper = ceMetaWrapper . WithLoc ics }+ local updateEnv $ runner i r+runInstrImpl runner (Meta meta i) r = do+ -- Add wrapper which will be used later on in loop-like instr.+ let updateEnv env@ContractEnv{..}+ = env { ceMetaWrapper = ceMetaWrapper . Meta meta }+ local updateEnv $ runner i r runInstrImpl _ Nop r = pure $ r runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r) runInstrImpl runner (Nested sq) r = runner sq r@@ -561,14 +610,14 @@ (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do res <- runner code (val :& curStack) case res of- ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))+ ((seValue -> nextVal :: Value b) :& nextStack) -> pure (nextStack, nextVal : curList)) (r, []) ((\el -> StkEl el) <$> mapOpToList @c a) pure $ StkEl (mapOpFromList a (reverse newList)) :& newStack runInstrImpl runner (ITER (code :: Instr (IterOpEl c ': s) s)) (StkEl a :& r) = case iterOpDetachOne @c a of (Just x, xs) -> do res <- runner code (StkEl x :& r)- runner (ITER code) (StkEl xs :& res)+ withMetaWrapper runner (ITER code) (StkEl xs :& res) (Nothing, _) -> pure r runInstrImpl _ AnnMEM{} (a :& b :& r) = pure $ StkEl (VBool (evalMem (seValue a) (seValue b))) :& r runInstrImpl _ AnnGET{} (a :& b :& r) = pure $ StkEl (VOption (evalGet (seValue a) (seValue b))) :& r@@ -600,29 +649,29 @@ :& r runInstrImpl runner (IF bTrue _) (StkEl (VBool True) :& r) = runner bTrue r runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) :& r) = runner bFalse r-runInstrImpl _ (LOOP _) (StkEl (VBool False) :& r) = pure $ r+runInstrImpl _ (LOOP _) (StkEl (VBool False) :& r) = pure r runInstrImpl runner (LOOP ops) (StkEl (VBool True) :& r) = do res <- runner ops r- runner (LOOP ops) res+ withMetaWrapper runner (LOOP ops) res runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) :& r) = pure $ StkEl a :& r runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) :& r) = do res <- runner ops (StkEl a :& r)- runner (LOOP_LEFT ops) res+ withMetaWrapper runner (LOOP_LEFT ops) res runInstrImpl _ (AnnLAMBDA _ lam) r = pure $ StkEl (mkVLam lam) :& r runInstrImpl _ (AnnLAMBDA_REC _ lam) r = pure $ StkEl (mkVLamRec lam) :& r runInstrImpl runner AnnEXEC{} (a :& self@(StkEl (VLam code)) :& r) = case code of- LambdaCode (T.rfAnyInstr -> lBody) -> do+ LambdaCode (rfAnyInstr -> lBody) -> do res <- runner lBody (a :& RNil) pure $ res <+> r- LambdaCodeRec (T.rfAnyInstr -> lBody) -> do+ LambdaCodeRec (rfAnyInstr -> lBody) -> do res <- runner lBody (a :& self :& RNil) pure $ res <+> r-runInstrImpl _ i@AnnAPPLY{} (StkEl (a :: T.Value a) :& StkEl (VLam code) :& r)+runInstrImpl _ i@AnnAPPLY{} (StkEl (a :: Value a) :& StkEl (VLam code) :& r) | _ :: Instr (a : 'TLambda ('TPair a b) c : s) ('TLambda b c : s) <- i , _ :: LambdaCode' Instr ('TPair a b) c <- code = case code of- LambdaCode lBody -> pure $ StkEl (VLam $ LambdaCode (T.rfMapAnyInstr doApply lBody)) :& r+ LambdaCode lBody -> pure $ StkEl (VLam $ LambdaCode (rfMapAnyInstr doApply lBody)) :& r LambdaCodeRec lBody -> let res = RfNormal $ PUSH a `Seq` PAIR `Seq` LAMBDA_REC lBody `Seq` SWAP `Seq` EXEC in pure $ StkEl (VLam $ LambdaCode res) :& r@@ -668,7 +717,7 @@ runInstrImpl _ AnnNOT{} ((seValue -> a) :& rest) = pure $ StkEl (evalUnaryArithOp (Proxy @Not) a) :& rest runInstrImpl _ AnnCOMPARE{} ((seValue -> l) :& (seValue -> r) :& rest) =- pure $ StkEl (T.VInt (compareOp l r)) :& rest+ pure $ StkEl (VInt (compareOp l r)) :& rest runInstrImpl _ AnnEQ{} ((seValue -> a) :& rest) = pure $ StkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest runInstrImpl _ AnnNEQ{} ((seValue -> a) :& rest) =@@ -683,48 +732,38 @@ pure $ StkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest runInstrImpl _ AnnINT{} (StkEl a :& r) = pure $ StkEl (evalToIntOp a) :& r+runInstrImpl _ AnnNAT{} (StkEl a :& r) =+ pure $ StkEl (evalToNatOp a) :& r+runInstrImpl _ AnnBYTES{} (StkEl a :& r) =+ pure $ StkEl (evalToBytesOp a) :& r runInstrImpl runner (AnnVIEW (Anns2' _ (_ :: Notes ret)) name)- (StkEl (arg :: Value arg) :& StkEl (VAddress epAddr) :& r) = do- ContractEnv{..} <- ask+ (StkEl (viewArg :: Value arg) :& StkEl (VAddress epAddr) :& r) = do res :: Value ('TOption ret) <- VOption <$> runMaybeT do EpAddress addr@ContractAddress{} _ <- pure epAddr- Just viewedContractState <- pure $ Map.lookup addr ceContracts ContractState { csContract = viewedContract , csStorage = viewedContractStorage- } <- pure viewedContractState- Just view_ <- pure $ lookupView name (cViews viewedContract)- SomeView (View{ vCode } :: View arg' st ret') <- pure view_- Just Refl <- pure $ sing @arg `decideEquality` sing @arg'- Just Refl <- pure $ sing @ret `decideEquality` sing @ret'- resSt <- lift $- local (mkViewEnv addr viewedContractState) $- runInstrImpl runner vCode $- StkEl (VPair (arg, viewedContractStorage)) :& RNil- let StkEl res :& RNil = resSt- return res+ , csBalance = viewedContractBalance+ } <- MaybeT $ asks ceContracts >>= ($ addr)+ view' <- hoistMaybe $ rightToMaybe $ getViewByNameAndType viewedContract name+ let viewEnv ContractEnv{..} = ContractEnv+ { ceAmount = zeroMutez+ , ceSelf = addr+ , ceSender = Constrained ceSelf+ , ceBalance = viewedContractBalance+ , ..+ }+ lift $ interpretView' runner viewEnv view' viewedContractStorage viewArg pure (StkEl res :& r)- where- mkViewEnv :: ContractAddress -> ContractState -> ContractEnv -> ContractEnv- mkViewEnv calledAddr viewedContractState ContractEnv{..} = ContractEnv- { ceBalance = csBalance viewedContractState- , ceSender = Constrained ceSelf- , ceSelf = calledAddr- , ceSource- , ceAmount = zeroMutez- , ceContracts- , ceNow, ceMaxSteps, ceVotingPowers, ceChainId, ceOperationHash, ceLevel- , ceErrorSrcPos, ceMinBlockTime- } runInstrImpl _ (AnnSELF _ sepc :: Instr inp out) r = do ContractEnv{..} <- ask case Proxy @out of (_ :: Proxy ('TContract cp ': s)) -> do pure $ StkEl (VContract (MkAddress ceSelf) sepc) :& r-runInstrImpl _ (AnnCONTRACT (Anns2' _ (_ :: T.Notes a)) instrEpName) (StkEl (VAddress epAddr) :& r) = do+runInstrImpl _ (AnnCONTRACT (Anns2' _ (_ :: Notes a)) instrEpName) (StkEl (VAddress epAddr) :& r) = do ContractEnv{..} <- ask- T.EpAddress' (Constrained addr) addrEpName <- pure epAddr+ EpAddress' (Constrained addr) addrEpName <- pure epAddr let mepName = case (instrEpName, addrEpName) of (DefEpName, DefEpName) -> Just DefEpName@@ -733,27 +772,27 @@ _ -> Nothing let withNotes v = StkEl v :& r- withNotes <$> case mepName of- Nothing -> pure $ VOption Nothing+ withNotes . VOption <$> case mepName of+ Nothing -> pure Nothing Just epName -> case addr of- ImplicitAddress{} -> pure $ castContract addr epName T.tyImplicitAccountParam- ContractAddress{} -> pure $- case Map.lookup addr ceContracts of- Just ContractState{..} ->- castContract addr epName (cParamNotes csContract)- Nothing -> VOption Nothing- TxRollupAddress{} ->- -- TODO [#838]: support transaction rollups on the emulator- throwMichelson $ MichelsonUnsupported "txr1 addresses with CONTRACT"+ ImplicitAddress{} -> pure $ case sing @a of+ STTicket{} -> castContract addr epName $ starParamNotes @a+ STUnit -> castContract addr epName $ starParamNotes @a+ _ -> Nothing+ ContractAddress{} -> runMaybeT do+ ContractState{csContract} <- MaybeT $ ceContracts addr+ hoistMaybe $ castContract addr epName (cParamNotes csContract)+ SmartRollupAddress{} ->+ throwMichelson $ MichelsonUnsupported "sr1 addresses with CONTRACT" where- castContract- :: forall p kind. (T.ParameterScope p)- => KindedAddress kind -> EpName -> T.ParamNotes p -> T.Value ('TOption ('TContract a))- castContract addr epName param = VOption $ do- -- As we are within Maybe monad, pattern-match failure results in Nothing- MkEntrypointCallRes (_ :: Notes a') epc <- T.mkEntrypointCall epName param- Right Refl <- pure $ eqType @a @a'- return $ VContract (MkAddress addr) (T.SomeEpc epc)+ castContract+ :: forall p kind. (ParameterScope p)+ => KindedAddress kind -> EpName -> ParamNotes p -> Maybe (Value ('TContract a))+ castContract addr epName param = do+ -- As we are within Maybe monad, pattern-match failure results in Nothing+ MkEntrypointCallRes (_ :: Notes a') epc <- mkEntrypointCall epName param+ Right Refl <- pure $ eqType @a @a'+ pure $ VContract (MkAddress addr) (SomeEpc epc) runInstrImpl _ AnnTRANSFER_TOKENS{} (StkEl p :& StkEl (VMutez mutez) :& StkEl contract :& r) = do@@ -905,18 +944,77 @@ runUnpack :: forall t. (UnpackedValScope t) => ByteString- -> Either UnpackError (T.Value t)+ -> Either UnpackError (Value t) runUnpack bs = -- TODO [TM-80]: Gas consumption here should depend on unpacked data size -- and size of resulting expression, errors would also spend some (all equally). -- Fortunately, the inner decoding logic does not need to know anything about gas use. unpackValue' bs +data ViewLookupError+ = ViewNotFound ViewName+ | ViewArgMismatch (MismatchError T)+ | ViewRetMismatch (MismatchError T)+ deriving stock Show++instance Buildable ViewLookupError where+ build = \case+ ViewNotFound name -> "View '" +| name |+ "' not found"+ ViewArgMismatch err -> "View argument type mismatch: " +| err |+ ""+ ViewRetMismatch err -> "View return type mismatch: " +| err |+ ""++-- | Interpret a contract's view for given t'ContractEnv' and initial+-- 'InterpreterState'. It is assumed t'ContractEnv' is suitable for the view+-- call, that is, the view is executed exactly in the env that's passed here.+interpretView+ :: View arg st ret+ -> Value st+ -> Value arg+ -> ContractEnv+ -> InterpreterState+ -> InterpretReturn ret+interpretView view' st argument = runEvalOp $ interpretView' runInstr id view' st argument++-- | Attempt to find a view with a given name and given type in a given+-- contract.+getViewByNameAndType+ :: forall arg ret cp st. (SingI arg, SingI ret)+ => Contract cp st -> ViewName -> Either ViewLookupError (View arg st ret)+getViewByNameAndType contract name = do+ SomeView (view'@View{} :: View arg' st ret') <- liftEither $ getViewByName contract name+ let retMismatch = ViewRetMismatch MkMismatchError+ { meActual = demote @ret', meExpected = demote @ret }+ argMismatch = ViewArgMismatch MkMismatchError+ { meActual = demote @arg', meExpected = demote @arg }+ Refl <- liftEither $ maybeToRight argMismatch $ sing @arg `decideEquality` sing @arg'+ Refl <- liftEither $ maybeToRight retMismatch $ sing @ret `decideEquality` sing @ret'+ pure view'++-- | Attempt to find a view with a given name in a given contract.+getViewByName :: Contract cp st -> ViewName -> Either ViewLookupError (SomeView st)+getViewByName contract name =+ liftEither $ maybeToRight (ViewNotFound name) $ lookupView name (cViews contract)++-- | 'EvalM' view interpretation helper.+interpretView'+ :: forall ret st m arg ext. EvalM' ext m+ => (forall inp out. Instr inp out -> Rec StkEl inp -> m (Rec StkEl out))+ -> (ContractEnv' m -> ContractEnv' m)+ -> View arg st ret+ -> Value st+ -> Value arg+ -> m (Value ret)+interpretView' runner env View{vCode} storage argument = do+ resSt <- local env $ runInstrImpl runner vCode $+ StkEl (VPair (argument, storage)) :& RNil+ let StkEl res :& RNil = resSt+ pure res+ createOrigOp :: (ParameterScope param, StorageScope store, L1AddressKind kind) => KindedAddress kind -> Maybe ContractAlias- -> Maybe (T.Value 'T.TKeyHash)+ -> Maybe (Value 'TKeyHash) -> Mutez -> Contract param store -> Value' Instr store@@ -933,34 +1031,34 @@ , ooAlias = mbAlias } -unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash+unwrapMbKeyHash :: Maybe (Value 'TKeyHash) -> Maybe KeyHash unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash interpretExt :: EvalM' ext m => InstrRunner m -> SomeItStack -> m ()-interpretExt _ (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do+interpretExt _ (SomeItStack (PRINT (PrintComment pc)) st) = do let getEl (Left l) = l getEl (Right str) = withStackElem str st (pretty . seValue) tell . one $ mconcat (map getEl pc) -interpretExt runner (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do+interpretExt runner (SomeItStack (TEST_ASSERT (TestAssert nm pc instr)) st) = do ost <- runInstrImpl runner instr st- let ((seValue -> T.fromVal -> succeeded) :& _) = ost+ let ((seValue -> fromVal -> succeeded) :& _) = ost unless succeeded $ do- interpretExt runner (SomeItStack (T.PRINT pc) st)+ interpretExt runner (SomeItStack (PRINT pc) st) throwMichelson $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed" -interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass-interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass-interpretExt _ (SomeItStack T.STACKTYPE{} _) = pass+interpretExt _ (SomeItStack DOC_ITEM{} _) = pass+interpretExt _ (SomeItStack COMMENT_ITEM{} _) = pass+interpretExt _ (SomeItStack STACKTYPE{} _) = pass -- | Access given stack reference (in CPS style). withStackElem :: forall st a.- T.StackRef st+ StackRef st -> Rec StkEl st -> (forall t. StkEl t -> a) -> a-withStackElem (T.StackRef sn) vals cont =+withStackElem (StackRef sn) vals cont = loop (vals, sn) where loop
src/Morley/Michelson/Macro.hs view
@@ -152,88 +152,65 @@ expandList :: [ParsedOp] -> [ExpandedOp] expandList = fmap expand--expandView :: View' ParsedOp -> View-expandView v = v{ viewCode = expandList (viewCode v) }+{-# DEPRECATED expandList "Use 'map expand' instead" #-} -- | Expand all macros in parsed contract. expandContract :: Contract' ParsedOp -> Contract-expandContract contract =- contract- { contractCode = expandList (contractCode contract)- , contractViews = expandView <$> contractViews contract- }+expandContract = fmap expand --- Probably, some SYB can be used here+-- | Expand all macros in parsed value. expandValue :: ParsedValue -> Value-expandValue = \case- ValuePair l r -> ValuePair (expandValue l) (expandValue r)- ValueLeft x -> ValueLeft (expandValue x)- ValueRight x -> ValueRight (expandValue x)- ValueSome x -> ValueSome (expandValue x)- ValueNil -> ValueNil- ValueSeq valueList -> ValueSeq (map expandValue valueList)- ValueMap eltList -> ValueMap (map expandElt eltList)- ValueLambda opList ->- maybe ValueNil ValueLambda $- nonEmpty (expandList $ toList opList)- x -> fmap expand x--expandElt :: Elt ParsedOp -> Elt ExpandedOp-expandElt (Elt l r) = Elt (expandValue l) (expandValue r)+expandValue = fmap expand expand :: ParsedOp -> ExpandedOp expand = let ics pos = ErrorSrcPos pos in \case+ (Mac m pos) -> WithSrcEx (ics pos) $ either PrimEx SeqEx $ expandMacro' (ics pos) m+ (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand <$> i+ (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand <$> s++expandMacro' :: ErrorSrcPos -> Macro -> Either ExpandedInstr [ExpandedOp]+expandMacro' p@ErrorSrcPos{unErrorSrcPos=macroPos} = \case+ -- special cases -- We handle this case specially, because it's essentially just PAIR. -- It's needed because we have a hack in parser: we parse PAIR as PAPAIR. -- We need to do something better eventually.- (Mac (PAPAIR (P (F a) (F b)) t v) pos) ->- WithSrcEx (ics pos) $ PrimEx (PAIR t v a b)+ PAPAIR (P (F a) (F b)) t v -> Left $ PAIR t v a b -- DIIP is now always represented as a single instruction.- -- `expandMacro` always returns a list which we wrap into `SeqEx`, so we- -- can't use it.- -- As the above comment says, we need to do something better eventually- -- (e. g. to avoid `error` usage inside `expandMacro`).- (Mac (DIIP n ops) pos) ->- WithSrcEx (ics pos) $ PrimEx (DIPN n (expand <$> ops))+ DIIP n ops -> Left $ DIPN n (expand <$> ops) -- Similarly to above, DUUP is now always represented as a single instruction.- (Mac (DUUP n v) pos) ->- WithSrcEx (ics pos) $ PrimEx $ DUPN v n- (Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m- (Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand <$> i- (Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand <$> s+ DUUP n v -> Left $ DUPN v n -expandMacro :: ErrorSrcPos -> Macro -> [ExpandedOp]-expandMacro p@ErrorSrcPos{unErrorSrcPos=macroPos} = \case- CMP i v -> [PrimEx (COMPARE v), xo i]- IFX i bt bf -> [xo i, PrimEx $ IF (xp bt) (xp bf)]- IFCMP i v bt bf -> PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)]- IF_SOME bt bf -> [PrimEx (IF_NONE (xp bf) (xp bt))]- IF_RIGHT bt bf -> [PrimEx (IF_LEFT (xp bf) (xp bt))]- FAIL -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]- ASSERT -> oprimEx $ IF [] (expandMacro p FAIL)- ASSERTX i -> [expand $ mac $ IFX i [] [mac FAIL]]- ASSERT_CMP i -> [expand $ mac $ IFCMP i noAnn [] [mac FAIL]]- ASSERT_NONE -> oprimEx $ IF_NONE [] (expandMacro p FAIL)- ASSERT_SOME -> oprimEx $ IF_NONE (expandMacro p FAIL) []- ASSERT_LEFT -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)- ASSERT_RIGHT -> oprimEx $ IF_LEFT (expandMacro p FAIL) []- PAPAIR ps t v -> expandPapair p ps t v- UNPAPAIR ps -> expandUnpapair p ps- CADR c v f -> expandCadr p c v f- CARN v idx -> [PrimEx (GETN v (2 * idx + 1))]- CDRN v idx -> [PrimEx (GETN v (2 * idx))]- SET_CADR c v f -> expandSetCadr p c v f- MAP_CADR c v f ops -> expandMapCadr p c v f ops- -- We handle DIIP and DUUP outside.- DIIP {} -> error "expandMacro DIIP is unreachable"- DUUP {} -> error "expandMacro DUUP is unreachable"+ -- regular cases+ CMP i v -> Right $ [PrimEx (COMPARE v), xo i]+ IFX i bt bf -> Right $ [xo i, PrimEx $ IF (xp bt) (xp bf)]+ IFCMP i v bt bf -> Right $ PrimEx <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)]+ IF_SOME bt bf -> Right $ [PrimEx (IF_NONE (xp bf) (xp bt))]+ IF_RIGHT bt bf -> Right $ [PrimEx (IF_LEFT (xp bf) (xp bt))]+ FAIL -> Right $ PrimEx <$> [UNIT noAnn noAnn, FAILWITH]+ ASSERT -> Right $ oprimEx $ IF [] fail'+ ASSERTX i -> Right $ [expand $ mac $ IFX i [] [mac FAIL]]+ ASSERT_CMP i -> Right $ [expand $ mac $ IFCMP i noAnn [] [mac FAIL]]+ ASSERT_NONE -> Right $ oprimEx $ IF_NONE [] fail'+ ASSERT_SOME -> Right $ oprimEx $ IF_NONE fail' []+ ASSERT_LEFT -> Right $ oprimEx $ IF_LEFT [] fail'+ ASSERT_RIGHT -> Right $ oprimEx $ IF_LEFT fail' []+ PAPAIR ps t v -> Right $ expandPapair p ps t v+ UNPAPAIR ps -> Right $ expandUnpapair p ps+ CADR c v f -> Right $ expandCadr p c v f+ CARN v idx -> Right $ [PrimEx (GETN v (2 * idx + 1))]+ CDRN v idx -> Right $ [PrimEx (GETN v (2 * idx))]+ SET_CADR c v f -> Right $ expandSetCadr p c v f+ MAP_CADR c v f ops -> Right $ expandMapCadr p c v f ops where+ fail' = expandMacro p FAIL mac = flip Mac macroPos oprimEx = one . PrimEx xo = PrimEx . fmap expand xp = fmap expand++expandMacro :: ErrorSrcPos -> Macro -> [ExpandedOp]+expandMacro = either (pure . PrimEx) id ... expandMacro' -- | The macro expansion rules below were taken from: https://tezos.gitlab.io/active/michelson.html#syntactic-conveniences --
src/Morley/Michelson/Optimizer.hs view
@@ -2,7 +2,7 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA -- NOTE this pragmas.--- We disable some wargnings for the sake of speed up.+-- We disable some warnings for the sake of speed up. -- Write code with care. {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-}@@ -14,6 +14,7 @@ module Morley.Michelson.Optimizer ( optimize , optimizeWithConf+ , optimizeVerboseWithConf , defaultOptimizerConf , defaultRules , defaultRulesAndPushPack@@ -22,34 +23,112 @@ , Rule (..) , OptimizerConf (..) , ocGotoValuesL+ -- * Ruleset manipulation+ , OptimizationStage (..)+ , Ruleset+ , rulesAtPrio+ , insertRuleAtPrio+ , clearRulesAtPrio+ , alterRulesAtPrio+ , OptimizerStageStats(..) ) where 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.Map qualified as Map import Data.Singletons (sing) import Data.Type.Equality ((:~:)(Refl))+import Fmt (Buildable(..), (+|), (|+)) import Morley.Michelson.Interpret.Pack (packValue')+import Morley.Michelson.Optimizer.Internal.Proofs import Morley.Michelson.Typed.Aliases (Value) import Morley.Michelson.Typed.Arith-import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.ClassifiedInstr+import Morley.Michelson.Typed.Instr hiding ((:#)) import Morley.Michelson.Typed.Scope (ConstantScope, PackedValScope, checkScope) import Morley.Michelson.Typed.Sing import Morley.Michelson.Typed.T-import Morley.Michelson.Typed.Util (DfsSettings(..), dfsModifyInstr)+import Morley.Michelson.Typed.Util (DfsSettings(..), dfsFoldInstr, dfsTraverseInstr) import Morley.Michelson.Typed.Value+import Morley.Util.Peano import Morley.Util.PeanoNatural +pattern (:#) :: Instr inp b -> Instr b out -> Instr inp out+pattern l :# r <- (maybeSeq -> Seq l r)+ where l :# Nop = l+ Nop :# r = r+ l :# r = Seq l r+infixr 8 :#++maybeSeq :: Instr inp out -> Instr inp out+maybeSeq = \case+ x@Seq{} -> x+ x -> Seq x Nop+ ---------------------------------------------------------------------------- -- High level ---------------------------------------------------------------------------- +-- | Optimization stages. Stages are run in first to last order, each stage has+-- an 'Int' argument, which allows splitting each stage into sub-stages, which+-- will run lowest index to highest. All default rules use sub-stage @0@.+data OptimizationStage+ = OptimizationStagePrepare Int+ | OptimizationStageMain Int+ -- ^ Main optimisation stage, except rules that would interfere with other+ -- rules.+ | OptimizationStageMainExtended Int+ -- ^ All main stage rules.+ | OptimizationStageRollAdjacent Int+ -- ^ Main stage rules unroll @DROP n@, @PAIR n@, etc into their primitive+ -- counterparts to simplify some optimisations. This stages coalesces them+ -- back.+ deriving stock (Eq, Ord)++instance Buildable OptimizationStage where+ build = \case+ OptimizationStagePrepare n -> "prepare " +| n |+ ""+ OptimizationStageMain n -> "main " +| n |+ ""+ OptimizationStageMainExtended n -> "main extended " +| n |+ ""+ OptimizationStageRollAdjacent n -> "roll adjacent " +| n |+ ""++-- | A set of optimization stages. Rules at the same sub-stage are applied in+-- arbitrary order. See 'OptimizationStage' for explanation of sub-stages.+--+-- 'Default' ruleset is empty.+newtype Ruleset = Ruleset { unRuleset :: Map OptimizationStage (NonEmpty Rule) }+ deriving newtype Default++instance Semigroup Ruleset where+ Ruleset l <> Ruleset r = Ruleset $ Map.unionWith (<>) l r++instance Monoid Ruleset where+ mempty = def++-- | Get rules for a given priority as a list.+rulesAtPrio :: OptimizationStage -> Ruleset -> [Rule]+rulesAtPrio prio = maybe [] toList . Map.lookup prio . unRuleset++-- | Insert a single rule at a given priority without touching other rules.+insertRuleAtPrio :: OptimizationStage -> Rule -> Ruleset -> Ruleset+insertRuleAtPrio = flip $ alterRulesAtPrio . (:)++-- | Remove the stage with the given priority.+clearRulesAtPrio :: OptimizationStage -> Ruleset -> Ruleset+clearRulesAtPrio = alterRulesAtPrio (const [])++-- | Alter all stage rules for a given priority.+alterRulesAtPrio :: ([Rule] -> [Rule]) -> OptimizationStage -> Ruleset -> Ruleset+alterRulesAtPrio f prio = Ruleset . Map.alter (nonEmpty . f . maybe [] toList) prio . unRuleset+ data OptimizerConf = OptimizerConf { ocGotoValues :: Bool- , ocRuleset :: [Rule]+ , ocRuleset :: Ruleset+ , ocMaxIterations :: Word } -- | Default config - all commonly useful rules will be applied to all the code.@@ -57,6 +136,7 @@ defaultOptimizerConf = OptimizerConf { ocGotoValues = True , ocRuleset = defaultRules+ , ocMaxIterations = 100 } instance Default OptimizerConf where@@ -71,81 +151,145 @@ -- | Optimize a typed instruction using a custom set of rules. -- The set is divided into several stages, as applying -- some rules can prevent others to be performed.+--+-- If any stage resulted in optimizations, we apply it again until we reach+-- fixpoint, but no more than 'ocMaxIterations' times. optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out-optimizeWithConf (OptimizerConf ocGotoValues rules) instr = foldl (flip performOneStage) instrRHS rules+optimizeWithConf = snd ... optimizeVerboseWithConf++data OptimizerStageStats = OptimizerStageStats+ { ossStage :: OptimizationStage+ , ossNumIterations :: Word+ , ossNumInstrs :: Word+ }++instance Buildable OptimizerStageStats where+ build OptimizerStageStats{..} =+ "Stage " +| ossStage+ |+ " finished after " +| ossNumIterations+ |+ " iterations. Instruction count: " +| ossNumInstrs |+ ""++-- | Returns some optimizer statistics in addition to optimized instruction.+-- Mostly useful for testing and debugging.+optimizeVerboseWithConf+ :: OptimizerConf+ -> Instr inp out+ -> ([OptimizerStageStats], Instr inp out)+optimizeVerboseWithConf OptimizerConf{..} instr =+ foldlM (performOneStage 1) instrRHS $ toPairs $ unRuleset ocRuleset where- dfsSettings = def{ dsGoToValues = ocGotoValues }- performOneStage stageRules =- dfsModifyInstr dfsSettings $ applyOnce stageRules- instrRHS = applyOnce (fixpoint flattenSeqLHS) instr+ performOneStage n i stage@(stageName, stageRules)+ | not changed || n >= ocMaxIterations = ([OptimizerStageStats stageName n stats], res)+ | otherwise = performOneStage (succ n) res stage+ where+ stats = getSum $ instrCount res+ instrCount = dfsFoldInstr def { dsGoToValues = ocGotoValues } $ withClassifiedInstr \case+ SFromMichelson -> const 1+ _ -> const 0+ stageRule = fixpoint $ foldl orSimpleRule flattenSeqLHS stageRules+ (getAny -> changed, res) =+ dfsTraverseInstr def{ dsGoToValues = ocGotoValues, dsInstrStep = applyOnce stageRule } i+ instrRHS = snd $ applyOnce (fixpoint flattenSeqLHS) instr ---------------------------------------------------------------------------- -- Rewrite rules ---------------------------------------------------------------------------- +{-+Note [Writing optimizer rules]+------------------------------++We locally redefine (:#) to simplify handling instruction sequence tails.+Consider that a given instruction sequence can appear in the middle, and then @a+:# b :# tail@ will match, or at the end of the sequence, and then @a :# b@ will+match.++Local definition of (:#) makes it so we can always assume there's a tail.+However, we don't need it when matching on single instructions.++Thus, the rule of thumb is this: if you're matching on a single instruction,+everything is fine. If you're matching on a sequence, i.e. using (:#), then+always match on tail.+-}+ -- Type of a single rewrite rule, wrapped in `newtype`. It takes an instruction -- and tries to optimize its head (first few instructions). If optimization -- succeeds, it returns `Just` the optimized instruction, otherwise it returns `Nothing`. newtype Rule = Rule {unRule :: forall inp out. Instr inp out -> Maybe (Instr inp out)} -defaultRules :: [Rule]-defaultRules = map fixpoint- [ mainStageRules- , glueAdjacentDropsStageRules+-- | Default optimization rules.+defaultRules :: Ruleset+defaultRules = foldr ($) def $ uncurry (alterRulesAtPrio . const) <$>+ -- NB: if adding more main stages, remember to check if+ -- 'defaultRulesAndPushPack' needs updating.+ [ (mainStageRules , OptimizationStageMain 0)+ , (dipDrop2swapDropStageRules , OptimizationStageMainExtended 0)+ , (glueAdjacentInstrsStageRules, OptimizationStageRollAdjacent 0) ] where- glueAdjacentDropsStageRules = flattenSeqLHS `orSimpleRule` adjacentDrops+ dipDrop2swapDropStageRules = dipDrop2swapDrop : mainStageRules+ glueAdjacentInstrsStageRules =+ [ adjacentDrops+ , rollPairN+ , rollUnpairN+ , rollDips+ ] --- | We do not enable 'pushPack' rule by default because it is--- potentially dangerous.--- There are various code processing functions that may depend on constants,--- e. g. string transformations.--- need helper-defaultRulesAndPushPack :: [Rule]-defaultRulesAndPushPack =- case defaultRules of- -- Perhaps one day main rules will not be performed on the first stage.- -- We need another way to add `pushPack` to `mainStageRules` in that case.- _ : otherStagesRules -> do- let mainStageRulesAndPushPack = fixpoint $ mainStageRules `orSimpleRule` pushPack- mainStageRulesAndPushPack : otherStagesRules- _ -> error "`defaultRules` should not be empty"+-- | We do not enable 'pushPack' rule by default because it is potentially+-- dangerous. There are various code processing functions that may depend on+-- constants, e. g. string transformations.+defaultRulesAndPushPack :: Ruleset+defaultRulesAndPushPack = defaultRules+ & insertRuleAtPrio (OptimizationStageMainExtended 0) pushPack -mainStageRules :: Rule -> Rule+mainStageRules :: [Rule] mainStageRules =- flattenSeqLHS- `orSimpleRule` removeNesting- `orSimpleRule` removeExtStackType- `orSimpleRule` dipDrop2swapDrop- `orSimpleRule` ifNopNop2Drop- `orSimpleRule` nopIsNeutralForSeq- `orSimpleRule` variousNops- `orSimpleRule` dupSwap2dup- `orSimpleRule` noDipNeeded- `orSimpleRule` branchShortCut- `orSimpleRule` compareWithZero- `orSimpleRule` simpleDrops- `orSimpleRule` internalNop- `orSimpleRule` simpleDips- `orSimpleRule` simpleDups- `orSimpleRule` adjacentDips- `orSimpleRule` isSomeOnIf- `orSimpleRule` redundantIf- `orSimpleRule` emptyDip- `orSimpleRule` digDug- `orSimpleRule` specificPush- `orSimpleRule` pairUnpair- `orSimpleRule` pairMisc- `orSimpleRule` unpairMisc- `orSimpleRule` swapBeforeCommutative- `orSimpleRule` justDrops- `orSimpleRule` justDoubleDrops+ [ removeNesting+ , removeExtStackType+ , ifNopNop2Drop+ , nopIsNeutralForSeq+ , variousNops+ , dupSwap2dup+ , noDipNeeded+ , branchShortCut+ , compareWithZero+ , internalNop+ , simpleDups+ , adjacentDips+ , isSomeOnIf+ , redundantIf+ , emptyDip+ , digDug+ , specificPush+ , pairUnpair+ , pairMisc+ , unpairMisc+ , swapBeforeCommutative+ , justDrops+ , justDoubleDrops+ , dig1AndDug1AreSwap+ , notIf+ , dropMeta+ -- strictly speaking, these rules below are de-optimisations, but they+ -- expose opportunities for other optimisations, and they are undone in the+ -- last stage.+ , unrollPairN+ , unrollUnpairN+ , unrollDropN+ , unrollDips+ ] flattenSeqLHS :: Rule -> Rule flattenSeqLHS toplevel = Rule $ \case it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it _ -> Nothing +dropMeta :: Rule+dropMeta = Rule $ \case+ Meta _ i -> Just i+ WithLoc _ i -> Just i+ _ -> Nothing+ removeNesting :: Rule removeNesting = Rule $ \case Nested i -> Just i@@ -169,9 +313,10 @@ nopIsNeutralForSeq :: Rule nopIsNeutralForSeq = Rule $ \case- Nop :# i -> Just i- i :# Nop -> Just i- _ -> Nothing+ -- NB: we're not using (:#) here because it'll always match when rhs is Nop+ Seq Nop i -> Just i+ Seq i Nop -> Just i+ _ -> Nothing variousNops :: Rule variousNops = Rule $ \case@@ -197,35 +342,11 @@ LEVEL :# DROP :# c -> Just c SELF_ADDRESS :# DROP :# c -> Just c READ_TICKET :# DROP :# c -> Just c-- DUP :# DROP -> Just Nop- DUPN _ :# DROP -> Just Nop- SWAP :# SWAP -> Just Nop- PUSH _ :# DROP -> Just Nop- NONE :# DROP -> Just Nop- UNIT :# DROP -> Just Nop- NIL :# DROP -> Just Nop- EMPTY_SET :# DROP -> Just Nop- EMPTY_MAP :# DROP -> Just Nop- EMPTY_BIG_MAP :# DROP -> Just Nop- LAMBDA _ :# DROP -> Just Nop- SELF _ :# DROP -> Just Nop- NOW :# DROP -> Just Nop- AMOUNT :# DROP -> Just Nop- BALANCE :# DROP -> Just Nop- TOTAL_VOTING_POWER :# DROP -> Just Nop- SOURCE :# DROP -> Just Nop- SENDER :# DROP -> Just Nop- CHAIN_ID :# DROP -> Just Nop- LEVEL :# DROP -> Just Nop- SELF_ADDRESS :# DROP -> Just Nop- READ_TICKET :# DROP -> Just Nop _ -> Nothing dupSwap2dup :: Rule dupSwap2dup = Rule $ \case- DUP :# SWAP :# c -> Just (DUP :# c)- DUP :# SWAP -> Just DUP+ DUP :# SWAP :# c -> Just $ DUP :# c _ -> Nothing noDipNeeded :: Rule@@ -233,104 +354,66 @@ -- If we put a constant value on stack and then do something under it, -- we can do this "something" on original stack and then put that constant. PUSH x :# DIP f :# c -> Just $ f :# PUSH x :# c- PUSH x :# DIP f -> Just $ f :# PUSH x UNIT :# DIP f :# c -> Just $ f :# UNIT :# c- UNIT :# DIP f -> Just $ f :# UNIT NOW :# DIP f :# c -> Just $ f :# NOW :# c- NOW :# DIP f -> Just $ f :# NOW SENDER :# DIP f :# c -> Just $ f :# SENDER :# c- SENDER :# DIP f -> Just $ f :# SENDER EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c- EMPTY_MAP :# DIP f -> Just $ f :# EMPTY_MAP EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c- EMPTY_SET :# DIP f -> Just $ f :# EMPTY_SET -- If we do something ignoring top of the stack and then immediately -- drop top of the stack, we can drop that item in advance and -- not use 'DIP' at all. DIP f :# DROP :# c -> Just $ DROP :# f :# c- DIP f :# DROP -> Just $ DROP :# f _ -> Nothing +unrollDips :: Rule+unrollDips = Rule go+ where+ go :: Instr inp out -> Maybe (Instr inp out)+ go = \case+ DIPN Zero c -> Just $ c+ DIPN One c -> Just $ DIP c+ DIPN (Succ n) c -> DIP <$> go (DIPN n c)+ _ -> Nothing++rollDips :: Rule+rollDips = Rule $ \case+ DIP (DIP c) -> Just $ DIPN Two c+ DIP (DIPN n c) -> Just $ DIPN (Succ n) c+ _ -> Nothing+ branchShortCut :: Rule branchShortCut = Rule $ \case- LEFT :# IF_LEFT f _ :# c -> Just (f :# c)- RIGHT :# IF_LEFT _ f :# c -> Just (f :# c)- CONS :# IF_CONS f _ :# c -> Just (f :# c)- NIL :# IF_CONS _ f :# c -> Just (f :# c)- NONE :# IF_NONE f _ :# c -> Just (f :# c)- SOME :# IF_NONE _ f :# c -> Just (f :# c)+ LEFT :# IF_LEFT f _ :# c -> Just $ f :# c+ RIGHT :# IF_LEFT _ f :# c -> Just $ f :# c+ CONS :# IF_CONS f _ :# c -> Just $ f :# c+ NIL :# IF_CONS _ f :# c -> Just $ f :# c+ NONE :# IF_NONE f _ :# c -> Just $ f :# c+ SOME :# IF_NONE _ f :# c -> Just $ f :# c PUSH vOr@(VOr eitherVal) :# IF_LEFT f g :# c -> case vOr of (_ :: Value ('TOr l r)) -> case eitherVal of Left val -> case checkScope @(ConstantScope l) of- Right Dict -> Just (PUSH val :# f :# c)- _ -> Nothing- Right val -> case checkScope @(ConstantScope r) of- Right Dict -> Just (PUSH val :# g :# c)- _ -> Nothing- PUSH (VList (x : xs)) :# IF_CONS f _ :# c -> Just (PUSH (VList xs) :# PUSH x :# f :# c)- PUSH (VList _) :# IF_CONS _ f :# c -> Just (f :# c)- PUSH (VOption Nothing) :# IF_NONE f _ :# c -> Just (f :# c)- PUSH (VOption (Just val)) :# IF_NONE _ f :# c -> Just (PUSH val :# f :# c)- PUSH (VBool True) :# IF f _ :# c -> Just (f :# c)- PUSH (VBool False) :# IF _ f :# c -> Just (f :# c)-- LEFT :# IF_LEFT f _ -> Just f- RIGHT :# IF_LEFT _ f -> Just f- CONS :# IF_CONS f _ -> Just f- NIL :# IF_CONS _ f -> Just f- NONE :# IF_NONE f _ -> Just f- SOME :# IF_NONE _ f -> Just f-- PUSH vOr@(VOr eitherVal) :# IF_LEFT f g -> case vOr of- (_ :: Value ('TOr l r)) -> case eitherVal of- Left val -> case checkScope @(ConstantScope l) of- Right Dict -> Just (PUSH val :# f)+ Right Dict -> Just $ PUSH val :# f :# c _ -> Nothing Right val -> case checkScope @(ConstantScope r) of- Right Dict -> Just (PUSH val :# g)+ Right Dict -> Just $ PUSH val :# g :# c _ -> Nothing- PUSH (VList (x : xs)) :# IF_CONS f _ -> Just (PUSH (VList xs) :# PUSH x :# f)- PUSH (VList _) :# IF_CONS _ f -> Just f- PUSH (VOption Nothing) :# IF_NONE f _ -> Just f- PUSH (VOption (Just val)) :# IF_NONE _ f -> Just (PUSH val :# f)- PUSH (VBool True) :# IF f _ -> Just f- PUSH (VBool False) :# IF _ f -> Just f-+ PUSH (VList (x : xs)) :# IF_CONS f _ :# c -> Just $ PUSH (VList xs) :# PUSH x :# f :# c+ PUSH (VList _) :# IF_CONS _ f :# c -> Just $ f :# c+ PUSH (VOption Nothing) :# IF_NONE f _ :# c -> Just $ f :# c+ PUSH (VOption (Just val)) :# IF_NONE _ f :# c -> Just $ PUSH val :# f :# c+ PUSH (VBool True) :# IF f _ :# c -> Just $ f :# c+ PUSH (VBool False) :# IF _ f :# c -> Just $ f :# c _ -> Nothing compareWithZero :: Rule compareWithZero = Rule $ \case PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c- PUSH (VInt 0) :# COMPARE :# EQ -> Just $ EQ- PUSH (VNat 0) :# COMPARE :# EQ -> Just $ INT :# EQ _ -> Nothing -simpleDrops :: Rule-simpleDrops = Rule $ \case- -- DROP 0 is Nop- DROPN Zero :# c -> Just c- DROPN Zero -> Just Nop-- -- DROP 1 is DROP.- -- @gromak: DROP seems to be cheaper (in my experiments it consumed 3 less gas).- -- It is packed more efficiently.- -- Unfortunately I do not know how to convince GHC that types match here.- -- Specifically, it can not deduce that `inp` is not empty- -- (`DROP` expects non-empty input).- -- We have `LongerOrSameLength inp (S Z)` here, but that is not enough to- -- convince GHC.- -- I will leave this note and rule here in hope that someone will manage to- -- deal with this problem one day.-- -- DROPN One :# c -> Just (DROP :# c)- -- DROPN One -> Just DROP-- _ -> Nothing- -- If an instruction takes another instruction as an argument and that -- internal instruction is 'Nop', sometimes the whole instruction is -- 'Nop'.@@ -339,42 +422,24 @@ internalNop :: Rule internalNop = Rule $ \case DIP Nop -> Just Nop- DIP Nop :# c -> Just c _ -> Nothing -simpleDips :: Rule-simpleDips = Rule $ \case- -- DIP 0 is redundant- DIPN Zero i :# c -> Just (i :# c)- DIPN Zero i -> Just i-- -- @gromak: same situation as with `DROP 1` (see above).- -- DIPN One i :# c -> Just (DIP i :# c)- -- DIPN One i -> Just (DIP i)-- _ -> Nothing- simpleDups :: Rule simpleDups = Rule $ \case -- DUP 1 is just DUP- DUPN One :# xs -> Just $ DUP :# xs- DUPN One -> Just $ DUP+ DUPN One -> Just DUP _ -> Nothing adjacentDips :: Rule adjacentDips = Rule $ \case- DIP f :# DIP g -> Just (DIP (f :# g))- DIP f :# DIP g :# c -> Just (DIP (f :# g) :# c)+ DIP f :# DIP g :# c -> Just $ DIP (f :# g) :# c _ -> Nothing redundantIf :: Rule redundantIf = Rule \case- IF x y :# xs- | x == y- -> Just $ DROP :# x :# xs IF x y | x == y -> Just $ DROP :# x@@ -382,39 +447,36 @@ 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- (DIG (x :: PeanoNatural n) :: Instr inp t) :# (DUG y :: Instr t out)- | Just Refl <- eqPeanoNat x y- -> Just Nop+ DIG x :# DUG y :# c | Just Refl <- eqPeanoNat x y -> Just c _ -> Nothing --- 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. -- When @n@ is 2 it saves gas only. adjacentDrops :: Rule adjacentDrops = Rule $ \case- DROP :# DROP -> Just (DROPN Two)- DROP :# DROP :# c -> Just (DROPN Two :# c)+ DROP :# DROP :# c -> Just $ DROPN Two :# c - -- Does not compile, need to do something smart- -- DROPN Two :# DROP -> Just (DROPN (Succ Two))+ (DROPN n :: Instr inp out) :# (DROP :: Instr inp' out') :# c+ -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' n One+ \\ commutativity (singPeanoNat n) (singPeanoNat One) + (DROP :: Instr inp out) :# (DROPN n :: Instr inp' out') :# c+ -> Just $ DROPN (Succ n) :# c \\ dropNDropNProof @inp @out @out' One n++ (DROPN n :: Instr inp out) :# (DROPN m :: Instr inp' out') :# c+ -> Just $ DROPN (addPeanoNat n m) :# c \\ dropNDropNProof @inp @out @out' n m+ _ -> Nothing specificPush :: Rule specificPush = Rule $ \case- push@PUSH{} -> optimizePush push push@PUSH{} :# c -> (:# c) <$> optimizePush push _ -> Nothing@@ -434,44 +496,88 @@ isSomeOnIf :: Rule isSomeOnIf = Rule $ \case- IF (PUSH (VOption Just{})) (PUSH (VOption Nothing)) :# c -> case c of- IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True)) :# s -> Just s- IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True)) -> Just Nop- _ -> Nothing+ IF (PUSH (VOption Just{})) (PUSH (VOption Nothing))+ :# IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))+ :# c+ -> Just c _ -> Nothing pairUnpair :: Rule pairUnpair = Rule $ \case PAIR :# UNPAIR :# c -> Just c- PAIR :# UNPAIR -> Just Nop UNPAIR :# PAIR :# c -> Just c- UNPAIR :# PAIR -> Just Nop _ -> Nothing pairMisc :: Rule pairMisc = Rule $ \case PAIR :# CDR :# c -> Just $ DROP :# c- PAIR :# CDR -> Just DROP PAIR :# CAR :# c -> Just $ (DIP DROP) :# c- PAIR :# CAR -> Just $ DIP DROP _ -> Nothing unpairMisc :: Rule unpairMisc = Rule $ \case- DUP :# CAR :# DIP CDR -> Just $ UNPAIR DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c - DUP :# CDR :# DIP CAR -> Just $ UNPAIR :# SWAP DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c - UNPAIR :# DROP -> Just CDR UNPAIR :# DROP :# c -> Just $ CDR :# c _ -> Nothing +unrollDropN :: Rule+unrollDropN = Rule go+ where+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)+ go = \case+ DROPN Zero -> Just Nop+ DROPN (Succ n) -> do+ dropn <- go $ DROPN n+ Just $ DROP :# dropn+ \\ unconsListProof @inp n+ _ -> Nothing++unrollPairN :: Rule+unrollPairN = Rule go+ where+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)+ go = \case+ PAIRN Two -> Just PAIR \\ pairN2isPairProof @inp+ PAIRN (Succ n@(Succ Succ{}) ) -> do+ pairn <- go $ PAIRN n+ Just $ DIP pairn :# PAIR+ \\ unconsListProof @inp n+ _ -> Nothing++unrollUnpairN :: Rule+unrollUnpairN = Rule go+ where+ go :: forall inp out. Instr inp out -> Maybe (Instr inp out)+ go = \case+ UNPAIRN Two -> Just UNPAIR \\ unpairN2isUnpairProof @inp @out+ UNPAIRN (Succ n@(Succ Succ{})) -> do+ unpairn <- go $ UNPAIRN n+ Just $ UNPAIR :# DIP unpairn+ \\ unpairNisUnpairDipUnpairNProof @inp @out n+ _ -> Nothing++rollPairN :: Rule+rollPairN = Rule $ \case+ DIP PAIR :# PAIR :# c -> Just $ PAIRN (Succ Two) :# c++ (DIP (PAIRN n@(Succ Succ{})) :: Instr inp out) :# PAIR :# c -> Just $ PAIRN (Succ n) :# c+ \\ dipPairNPairIsPairNProof @inp n++ _ -> Nothing++rollUnpairN :: Rule+rollUnpairN = Rule $ \case+ UNPAIR :# DIP UNPAIR :# c -> Just $ UNPAIRN (Succ Two) :# c+ UNPAIR :# DIP (UNPAIRN n@(Succ Succ{})) :# c -> Just $ UNPAIRN (Succ n) :# c+ _ -> Nothing+ commuteArith :: forall n m s out. Instr (n ': m ': s) out -> Maybe (Instr (m ': n ': s) out) commuteArith = \case@@ -485,14 +591,12 @@ swapBeforeCommutative :: Rule swapBeforeCommutative = Rule $ \case SWAP :# i :# c -> (:# c) <$> commuteArith i- SWAP :# i -> commuteArith i _ -> Nothing pushPack :: Rule pushPack = Rule $ \case- PUSH x :# PACK -> Just (pushPacked x)- PUSH x :# PACK :# c -> Just (pushPacked x :# c)+ PUSH x :# PACK :# c -> Just $ pushPacked x :# c _ -> Nothing where@@ -537,43 +641,6 @@ PAIRING_CHECK :# DROP :# c -> Just $ DROP :# c ADDRESS :# DROP :# c -> Just $ DROP :# c JOIN_TICKETS :# DROP :# c -> Just $ DROP :# c-- CAR :# DROP -> Just DROP- CDR :# DROP -> Just DROP- SOME :# DROP -> Just DROP- LEFT :# DROP -> Just DROP- RIGHT :# DROP -> Just DROP- SIZE :# DROP -> Just DROP- GETN _ :# DROP -> Just DROP- CAST :# DROP -> Just DROP- RENAME :# DROP -> Just DROP- PACK :# DROP -> Just DROP- UNPACK :# DROP -> Just DROP- CONCAT' :# DROP -> Just DROP- ISNAT :# DROP -> Just DROP- ABS :# DROP -> Just DROP- NEG :# DROP -> Just DROP- NOT :# DROP -> Just DROP- EQ :# DROP -> Just DROP- NEQ :# DROP -> Just DROP- LT :# DROP -> Just DROP- GT :# DROP -> Just DROP- LE :# DROP -> Just DROP- GE :# DROP -> Just DROP- INT :# DROP -> Just DROP- CONTRACT _ :# DROP -> Just DROP- SET_DELEGATE :# DROP -> Just DROP- IMPLICIT_ACCOUNT :# DROP -> Just DROP- VOTING_POWER :# DROP -> Just DROP- SHA256 :# DROP -> Just DROP- SHA512 :# DROP -> Just DROP- BLAKE2B :# DROP -> Just DROP- SHA3 :# DROP -> Just DROP- KECCAK :# DROP -> Just DROP- HASH_KEY :# DROP -> Just DROP- PAIRING_CHECK :# DROP -> Just DROP- ADDRESS :# DROP -> Just DROP- JOIN_TICKETS :# DROP -> Just DROP _ -> Nothing justDoubleDrops :: Rule@@ -595,25 +662,17 @@ TICKET :# DROP :# c -> Just $ DROP :# DROP :# c SPLIT_TICKET :# DROP :# c -> Just $ DROP :# DROP :# c SWAP :# DROP :# DROP :# c -> Just $ DROP :# DROP :# c+ _ -> Nothing - PAIR :# DROP -> Just $ DROP :# DROP- MEM :# DROP -> Just $ DROP :# DROP- GET :# DROP -> Just $ DROP :# DROP- APPLY :# DROP -> Just $ DROP :# DROP- 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- AND :# DROP -> Just $ DROP :# DROP- XOR :# DROP -> Just $ DROP :# DROP- COMPARE :# DROP -> Just $ DROP :# DROP- TICKET :# DROP -> Just $ DROP :# DROP- SPLIT_TICKET :# DROP -> Just $ DROP :# DROP- SWAP :# DROP :# DROP -> Just $ DROP :# DROP+dig1AndDug1AreSwap :: Rule+dig1AndDug1AreSwap = Rule \case+ DUG One -> Just SWAP+ DIG One -> Just SWAP+ _ -> Nothing +notIf :: Rule+notIf = Rule \case+ (NOT :: Instr inp out) :# IF a b :# c | STBool <- sing @(Head inp) -> Just $ IF b a :# c _ -> Nothing -- | Append LHS of v'Seq' to RHS and re-run pointwise ocRuleset at each point.@@ -626,7 +685,7 @@ -- -- The argument is a local, non-structurally-recursive ocRuleset. linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out-linearizeAndReapply restart = \case+linearizeAndReapply restart = snd . \case Seq (Seq a b) c -> applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c)) @@ -654,15 +713,19 @@ go = whileApplies (r go) -- | 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)+--+-- Also returns a flag showing whether the rule succeeded or not.+applyOnce :: Rule -> Instr inp out -> (Any Bool, Instr inp out)+applyOnce r i = maybe (pure i) (Any True,) (unRule r $ i) -- | Apply a rule to the same code, until it fails. whileApplies :: Rule -> Rule-whileApplies r = Rule go+whileApplies r = Rule $ go <=< unRule r+ -- NB: if the rule doesn't apply even once, we want to return Nothing here,+ -- hence it's first applied above and only if successful goes into recursion. where go :: Instr inp out -> Maybe (Instr inp out)- go i = maybe (Just i) go (unRule r $ i)+ go i = maybe (Just i) go (unRule r i) ---------------------------------------------------------------------------- -- TH
+ src/Morley/Michelson/Optimizer/Internal/Proofs.hs view
@@ -0,0 +1,76 @@+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | Some internally used typelevel proofs.+module Morley.Michelson.Optimizer.Internal.Proofs+ ( module Morley.Michelson.Optimizer.Internal.Proofs+ ) where++import Prelude hiding (EQ, GT, LT)++import Data.Constraint (Dict(..), (\\))+import Data.Type.Equality ((:~:)(..))++import Morley.Michelson.Typed (SingT(..), T(..))+import Morley.Michelson.Typed.Instr.Constraints+import Morley.Util.Peano+import Morley.Util.PeanoNatural+import Morley.Util.StubbedProof+import Morley.Util.Type++dropNDropNProof+ :: forall inp out out' n m.+ ( out ~ Drop n inp, IsLongerOrSameLength inp n ~ 'True+ , out' ~ Drop m out, IsLongerOrSameLength out m ~ 'True)+ => PeanoNatural n -> PeanoNatural m+ -> Dict (Drop (AddPeano n m) inp ~ out', IsLongerOrSameLength inp (AddPeano n m) ~ 'True)+dropNDropNProof Zero _ = Dict+dropNDropNProof (Succ n) m = Dict+ \\ stubProof @(Drop (AddPeano n m) inp) @out' case assumeKnown @inp of+ KCons _ (_ :: Proxy xs) -> Refl \\ dropNDropNProof @xs @out @out' n m+ \\ stubProof @(IsLongerOrSameLength inp (AddPeano n m)) @'True case assumeKnown @inp of+ KCons _ (_ :: Proxy xs) -> Refl \\ dropNDropNProof @xs @out @out' n m++unpairN2isUnpairProof+ :: forall inp out pair s. (inp ~ pair : s, out ~ UnpairN ('S ('S 'Z)) pair ++ s+ , ConstraintUnpairN (ToPeano 2) pair)+ => inp :~: PairN (ToPeano 2) out+unpairN2isUnpairProof = stubProof case assumeSing @pair of+ STPair{} -> case assumeKnown @out of+ KCons{} -> Refl+ where _ = Dict @(ConstraintUnpairN (ToPeano 2) pair)++unpairNisUnpairDipUnpairNProof+ :: forall inp out pair s n. (inp ~ pair : s, out ~ UnpairN ('S n) pair ++ s, ConstraintUnpairN ('S n) pair)+ => PeanoNatural n -> pair :~: RightComb (LazyTake ('S n) out)+unpairNisUnpairDipUnpairNProof n = stubProof case assumeSing @pair of+ STPair _ (_ :: SingT r) -> case n of+ Succ Zero -> Refl+ Succ m@Succ{} -> Refl \\ unpairNisUnpairDipUnpairNProof @(r : s) @(Tail out) m+ where _ = Dict @(inp ~ pair : s)++dipPairNPairIsPairNProof+ :: forall inp n. ( n >= ToPeano 2 ~ 'True, IsLongerOrSameLength (Tail inp) n ~ 'True+ , inp ~ Head inp : Tail inp)+ => PeanoNatural n+ -> PairN ('S n) inp :~: 'TPair (Head inp) (RightComb (LazyTake n (Tail inp))) : Drop n (Tail inp)+dipPairNPairIsPairNProof n = stubProof case (n, assumeKnown @inp) of+ (Succ Succ{}, KCons{}) -> Refl+ where _ = Dict @(n >= ToPeano 2 ~ 'True, IsLongerOrSameLength (Tail inp) n ~ 'True)++pairN2isPairProof+ :: forall inp. (IsLongerOrSameLength inp ('S ('S 'Z)) ~ 'True)+ => inp :~: Head inp : Head (Tail inp) : Drop ('S ('S 'Z)) inp+pairN2isPairProof = stubProof case assumeKnown @inp of+ KCons _ (_ :: Proxy xs) -> case klist @xs of+ KCons {} -> Refl+ where _ = Dict @(IsLongerOrSameLength inp ('S ('S 'Z)) ~ 'True)++unconsListProof+ :: forall inp n. (IsLongerOrSameLength inp ('S n) ~ 'True)+ => PeanoNatural n -> inp :~: Head inp : Tail inp+unconsListProof _ = stubProof case assumeKnown @inp of+ KCons{} -> Refl+ where _ = Dict @(IsLongerOrSameLength inp ('S n) ~ 'True)
src/Morley/Michelson/Parser.hs view
@@ -21,6 +21,7 @@ , parseNoEnv , parseValue , parseExpandValue+ , parseType -- * For tests , codeEntry@@ -131,7 +132,8 @@ (CBParam _, CBParam _ : _) -> failDuplicateField result (CBStorage _, CBStorage _: _) -> failDuplicateField result (CBCode _, CBCode _: _) -> failDuplicateField result- (CBView _, _) -> pure ()+ (CBView View{viewName=n1}, CBView View{viewName=n2} : _)+ | n1 == n2 -> failDuplicateField result (_, _:xs) -> ensureNotDuplicate xs result (_, []) -> pure () @@ -174,6 +176,9 @@ -- <BLANKLINE> parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue parseValue = first ParserException ... parseNoEnv value++parseType :: MichelsonSource -> Text -> Either ParserException Ty+parseType = first ParserException ... parseNoEnv type_ -- | Like 'parseValue', but also expands macros. parseExpandValue :: MichelsonSource -> Text -> Either ParserException U.Value
src/Morley/Michelson/Parser/Instr.hs view
@@ -54,6 +54,7 @@ , saplingEmptyStateOp, saplingVerifyUpdateOp, minBlockTimeOp , emitOp , lambdaRecOp opParser+ , natOp, bytesOp ] -- | Parse a sequence of instructions.@@ -459,6 +460,12 @@ intOp :: Parser ParsedInstr intOp = word "INT" INT <*> noteDef++natOp :: Parser ParsedInstr+natOp = word "NAT" NAT <*> noteDef++bytesOp :: Parser ParsedInstr+bytesOp = word "BYTES" BYTES <*> noteDef -- Ticket Operations
src/Morley/Michelson/Parser/Type.hs view
@@ -243,5 +243,5 @@ t_txRollupL2Address :: Default a => Parser a -> Parser (a, Ty) t_txRollupL2Address fp = do symbol1 "tx_rollup_l2_address"- (f,t) <- fieldType fp- return (f, Ty TTxRollupL2Address t)+ _ <- fieldType fp+ fail "Transaction rollups are not supported"
src/Morley/Michelson/Runtime.hs view
@@ -10,10 +10,14 @@ , runContract , transfer , runCode+ , runView , RunCodeParameters(..) , runCodeParameters , resolveRunCodeBigMaps , mkBigMapFinder+ , CommonRunOptions(..)+ , ContractSpecification (..)+ , ContractSimpleOriginationData(..) -- * Other helpers , parseContract@@ -53,6 +57,7 @@ , esOperationHash , esPrevCounters , ExecutorLog(..)+ , SomeInterpretResult(..) , elInterpreterResults , elUpdates ) where@@ -60,7 +65,7 @@ import Control.Lens (assign, at, each, ix, makeLenses, to, (.=), (<>=)) import Control.Monad.Except (Except, liftEither, runExcept, throwError) import Data.Constraint (Dict(..), (\\))-import Data.Default (def)+import Data.Default (Default(..)) import Data.HashSet qualified as HS import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) import Data.Singletons (demote)@@ -71,8 +76,6 @@ import Text.Megaparsec (parse) import Morley.Michelson.Interpret- (ContractEnv(..), InterpretError, InterpretResult(..), InterpreterState(..), MorleyLogs(..),- RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret) import Morley.Michelson.Macro (ParsedOp, expandContract) import Morley.Michelson.Parser qualified as P import Morley.Michelson.Runtime.Dummy@@ -80,9 +83,10 @@ import Morley.Michelson.Runtime.RunCode import Morley.Michelson.Runtime.TxData import Morley.Michelson.TypeCheck+import Morley.Michelson.TypeCheck.Helpers (checkContractDeprecations, checkSingDeprecations) import Morley.Michelson.Typed (Constrained(..), CreateContract(..), EntrypointCallT, EpName, Operation'(..),- SomeContractAndStorage(..), SomeStorage, TransferTokens(..), untypeValue)+ SomeContractAndStorage(..), SomeStorage, TransferTokens(..), sing) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation import Morley.Michelson.Untyped (Contract)@@ -92,7 +96,7 @@ import Morley.Tezos.Address.Kinds import Morley.Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez)-import Morley.Tezos.Crypto (KeyHash, parseHash)+import Morley.Tezos.Crypto (KeyHash) import Morley.Util.Interpolate (itu) import Morley.Util.MismatchError import Morley.Util.Named@@ -136,13 +140,19 @@ " with type " +| emNotes |+ " and value " +| emValue |+ "" +data SomeInterpretResult = forall st. SomeInterpretResult+ { unSomeInterpretResult :: InterpretResult st+ }++deriving stock instance Show SomeInterpretResult+ -- | Result of a single execution of interpreter. data ExecutorRes = ExecutorRes { _erGState :: GState -- ^ New 'GState'. , _erUpdates :: [GStateUpdate] -- ^ Updates applied to 'GState'.- , _erInterpretResults :: [(Address, InterpretResult)]+ , _erInterpretResults :: [(Address, SomeInterpretResult)] -- ^ During execution a contract can print logs and in the end it returns -- a pair. All logs and returned values are kept until all called contracts -- are executed. In the end they are printed.@@ -154,8 +164,9 @@ { _eeNow :: Timestamp , _eeLevel :: Natural , _eeMinBlockTime :: Natural+ , _eeTcOpts :: TypeCheckOptions }- deriving stock (Show, Generic)+ deriving stock (Generic) data ExecutorState = ExecutorState { _esGState :: GState@@ -169,7 +180,7 @@ data ExecutorLog = ExecutorLog { _elUpdates :: [GStateUpdate]- , _elInterpreterResults :: [(Address, InterpretResult)]+ , _elInterpreterResults :: [(Address, SomeInterpretResult)] } deriving stock (Show, Generic) deriving (Semigroup, Monoid) via GenericSemigroupMonoid ExecutorLog@@ -187,6 +198,10 @@ -- ^ The interpreted contract hasn't been originated. | EEInterpreterFailed a (InterpretError Void) -- ^ Interpretation of Michelson contract failed.+ | EEViewLookupError a ViewLookupError+ -- ^ Error looking up view while trying to call it.+ | EEViewArgTcError a TcError+ -- ^ Error type-checking untyped view argument. | EEUnknownAddressAlias SomeAlias -- ^ The given alias isn't associated with any address -- OR is associated with an address of an unexpected kind@@ -211,6 +226,8 @@ -- ^ Failed to apply updates to GState. | EEIllTypedParameter a TcError -- ^ Contract parameter is ill-typed.+ | EEDeprecatedType TcError+ -- ^ Found deprecated types. | EEUnexpectedParameterType a (MismatchError T.T) -- ^ Contract parameter is well-typed, but its type does -- not match the entrypoint's type.@@ -247,6 +264,10 @@ EEUnknownContract addr -> "The contract is not originated " +| addr |+ "" EEInterpreterFailed addr err -> "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""+ EEViewLookupError addr err ->+ nameF ("View lookup for contract " +| addr |+ " failed") $ build err+ EEViewArgTcError addr err ->+ nameF ("Typechecking view argument for contract " +| addr |+ " failed") $ build err EEUnknownSender addr -> "The sender address is unknown " +| addr |+ "" EEUnknownManager addr -> "The manager address is unknown " +| addr |+ "" EENotEnoughFunds addr amount ->@@ -258,6 +279,7 @@ "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 |+ ""+ EEDeprecatedType err -> nameF "Deprecation error" $ build err EEUnexpectedParameterType _ merr -> "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" +| merr |+ ""@@ -314,83 +336,47 @@ -- | Originate a contract. Returns the address of the originated -- contract. originateContract- :: FilePath- -> TypeCheckOptions- -> ImplicitAddress- -> Maybe ContractAlias- -> Maybe KeyHash- -> Mutez- -> U.Value- -> U.Contract- -> "verbose" :! Bool+ :: "dbPath" :! FilePath+ -> "tcOpts" :? TypeCheckOptions+ -> "originator" :? ImplicitAddress+ -> "alias" :? ContractAlias+ -> "delegate" :? KeyHash+ -> "csod" :! ContractSimpleOriginationData U.Contract+ -> "verbose" :? Bool -> IO ContractAddress-originateContract dbPath tcOpts originator mbAlias delegate balance uStorage uContract verbose = do- origination <- either throwM pure . typeCheckingWith tcOpts $- mkOrigination <$> typeCheckContractAndStorage uContract uStorage- -- pass 100500 as maxSteps, because it doesn't matter for origination,- -- as well as 'now'- fmap snd $ runExecutorMWithDB Nothing Nothing Nothing dbPath 100500 verbose (#dryRun :? Nothing) $ do+originateContract+ (arg #dbPath -> croDBPath)+ (argDef #tcOpts def -> croTCOpts)+ originator+ alias+ (argF #delegate -> mbDelegate)+ (arg #csod -> csod)+ (argDef #verbose False -> croVerbose)+ = do+ origination <- either throwM pure $+ mkOrigination croTCOpts csod originator alias ! #delegate mbDelegate+ let croDryRun = False+ fmap snd $ runExecutorMWithDB def{croDBPath, croDryRun, croVerbose, croTCOpts} $ executeGlobalOrigination origination- where- mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation- { ooOriginator = originator- , ooDelegate = delegate- , ooBalance = balance- , ooStorage = storage- , ooContract = contract- , ooCounter = 0- , ooAlias = mbAlias- } -- | Run a contract. The contract is originated first (if it's not -- already) and then we pretend that we send a transaction to it. runContract- :: Maybe Timestamp- -> Maybe Natural- -> Maybe Natural- -> Word64- -> Mutez- -> FilePath- -> TypeCheckOptions- -> U.Value- -> U.Contract+ :: CommonRunOptions+ -> ContractSimpleOriginationData U.Contract -> TxData- -> "verbose" :! Bool- -> "dryRun" :! Bool -> IO SomeStorage-runContract maybeNow maybeLevel maybeMinBlockTime maxSteps initBalance dbPath tcOpts uStorage uContract txData- verbose (arg #dryRun -> dryRun) = do- origination <- either throwM pure . typeCheckingWith tcOpts $- mkOrigination <$> typeCheckContractAndStorage uContract uStorage- (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath- (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do+runContract cro@CommonRunOptions{..} csOrig txData = do+ origination <- either throwM pure $ mkOrigination croTCOpts csOrig ! def+ (_, newSt) <- runExecutorMWithDB cro do -- Here we are safe to bypass executeGlobalOperations for origination, -- since origination can't generate more operations. addr <- executeGlobalOrigination origination let transferOp = TransferOp $ TransferOperation (MkAddress addr) txData 1- void $ executeGlobalOperations tcOpts [transferOp]+ void $ executeGlobalOperations [transferOp] getContractStorage addr return newSt where- -- We hardcode some random key hash here as delegate to make sure that:- -- 1. Contract's address won't clash with already originated one (because- -- it may have different storage value which may be confusing).- -- 2. If one uses this functionality twice with the same contract and- -- other data, the contract will have the same address.- delegate :: KeyHash- delegate =- either (error . mappend "runContract can't parse delegate: " . pretty) id $- parseHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"- mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation- { ooOriginator = genesisAddress- , ooDelegate = Just delegate- , ooBalance = initBalance- , ooStorage = storage- , ooContract = contract- , ooCounter = 0- , ooAlias = Nothing- }- getContractStorage :: ContractAddress -> ExecutorM SomeStorage getContractStorage addr = do addrs <- use (esGState . gsContractAddressesL)@@ -398,6 +384,92 @@ Nothing -> error $ pretty addr <> " is unknown" Just ContractState{..} -> return $ SomeStorage csStorage +data ContractSpecification a+ = ContractSpecAddressOrAlias ContractAddressOrAlias+ | ContractSpecOrigination a+ deriving stock (Functor, Foldable, Traversable)++data ContractSimpleOriginationData a = ContractSimpleOriginationData+ { csodContract :: a+ , csodStorage :: U.Value+ , csodBalance :: Mutez+ }+ deriving stock (Functor, Foldable, Traversable)++data CommonRunOptions = CommonRunOptions+ { croNow :: Maybe Timestamp+ , croLevel :: Natural+ , croMinBlockTime :: Natural+ , croMaxSteps :: RemainingSteps+ , croDBPath :: FilePath+ , croTCOpts :: TypeCheckOptions+ , croVerbose :: Bool+ , croDryRun :: Bool+ }++instance Default CommonRunOptions where+ def = CommonRunOptions+ { croNow = Nothing+ , croLevel = 0+ , croMinBlockTime = dummyMinBlockTime+ , croMaxSteps = dummyMaxSteps+ , croDBPath = "db.json"+ , croTCOpts = def+ , croVerbose = False+ , croDryRun = True+ }++-- | Run a contract view. The contract is originated first (if it's not already)+-- and then we pretend that we send a transaction to it.+runView+ :: CommonRunOptions+ -> ContractSpecification (ContractSimpleOriginationData U.Contract)+ -> U.ViewName+ -> SomeAddressOrAlias+ -> TxParam+ -> IO T.SomeValue+runView cro@CommonRunOptions{..} contractOrAddr viewName sender' viewArg = do+ origination <- traverse (either throwM pure . (mkOrigination croTCOpts ! def)) contractOrAddr+ (_, newSt) <- runExecutorMWithDB cro do+ addr <- case origination of+ ContractSpecAddressOrAlias addr -> resolveContractAddress addr+ ContractSpecOrigination origOp -> executeGlobalOrigination origOp+ -- Here we are safe to bypass executeGlobalOperations for origination,+ -- since origination can't generate more operations.+ sender <- resolveAddress sender'+ callView sender addr viewName viewArg+ return newSt++mkOrigination+ :: TypeCheckOptions+ -> ContractSimpleOriginationData U.Contract+ -> "originator" :? ImplicitAddress+ -> "alias" :? ContractAlias+ -> "delegate" :? Maybe KeyHash+ -> Either TcError OriginationOperation+mkOrigination tcOpts ContractSimpleOriginationData{..}+ (argDef #originator genesisAddress -> ooOriginator)+ (argF #alias -> ooAlias)+ (argDef #delegate (Just dummyDelegate) -> ooDelegate)+ = do+ SomeContractAndStorage ooContract ooStorage <- typeCheckingWith tcOpts $+ typeCheckContractAndStorage csodContract csodStorage+ pure OriginationOperation+ { ooBalance = csodBalance+ , ooCounter = 0+ , ..+ }++-- | We hardcode some random key hash here as delegate to make sure that:+--+-- 1. Contract's address won't clash with already originated one (because it may+-- have different storage value which may be confusing).+--+-- 2. If one uses this functionality twice with the same contract and other+-- data, the contract will have the same address.+dummyDelegate :: KeyHash+dummyDelegate = let ImplicitAddress kh = [ta|tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47|] in kh+ -- | Construct 'BigMapFinder' using the current executor context. mkBigMapFinder :: ExecutorM BigMapFinder mkBigMapFinder = do@@ -422,21 +494,15 @@ -- | Send a transaction to given address with given parameters. transfer- :: Maybe Timestamp- -> Maybe Natural- -> Maybe Natural- -> Word64- -> FilePath- -> TypeCheckOptions+ :: CommonRunOptions -> SomeAddressOrAlias -> TxData- -> "verbose" :! Bool- -> "dryRun" :? Bool -> IO ()-transfer maybeNow maybeLevel maybeMinBlockTime maxSteps dbPath tcOpts destination txData verbose dryRun = do- void $ runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath (RemainingSteps maxSteps) verbose dryRun $ do- destAddr <- resolveAddress destination- executeGlobalOperations tcOpts [TransferOp $ TransferOperation destAddr txData 0]+transfer cro destination txData = do+ -- TODO [#905]: simplify with convertAddress+ void $ runExecutorMWithDB @[EmitOperation] cro $ do+ Constrained destAddr <- resolveAddress destination+ executeGlobalOperations [TransferOp $ TransferOperation (MkAddress destAddr) txData 0] ---------------------------------------------------------------------------- -- Executor@@ -459,13 +525,14 @@ -> Natural -> Natural -> RemainingSteps+ -> TypeCheckOptions -> GState -> ExecutorM a -> Either ExecutorError (ExecutorRes, a)-runExecutorM now level minBlockTime remainingSteps gState action =+runExecutorM now level minBlockTime remainingSteps tcOpts gState action = fmap preResToRes $ runExcept- $ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime)+ $ runStateT (runReaderT action $ ExecutorEnv now level minBlockTime tcOpts) initialState where initialOpHash = error "Initial OperationHash touched"@@ -492,29 +559,18 @@ -- | Run some executor action, reading state from the DB on disk. ----- Unless @dryRun@ is @False@, the final state is written back to the disk.+-- If 'croDryRun' is @False@, the final state is written back to the disk. -- -- If the executor fails with 'ExecutorError' it will be thrown as an exception. runExecutorMWithDB- :: Maybe Timestamp- -> Maybe Natural- -> Maybe Natural- -> FilePath- -> RemainingSteps- -> "verbose" :! Bool- -> "dryRun" :? Bool+ :: CommonRunOptions -> ExecutorM a -> IO (ExecutorRes, a)-runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath remainingSteps- (arg #verbose -> verbose)- (argDef #dryRun False -> dryRun)- action = do+runExecutorMWithDB (CommonRunOptions mNow level minBlockTime steps dbPath tcOpts verbose dryRun) action = do gState <- readGState dbPath- now <- maybe getCurrentTime pure maybeNow- let level = fromMaybe 0 maybeLevel- mbt = fromMaybe dummyMinBlockTime maybeMinBlockTime+ now <- maybe getCurrentTime pure mNow (res@ExecutorRes{..}, a) <- either throwM pure $- runExecutorM now level mbt remainingSteps gState action+ runExecutorM now level minBlockTime steps tcOpts gState action unless dryRun $ writeGState dbPath _erGState@@ -527,15 +583,21 @@ return (res, a) where printInterpretResult- :: (Address, InterpretResult) -> IO ()- printInterpretResult (addr, InterpretResult {..}) = do+ :: (Address, SomeInterpretResult) -> IO ()+ printInterpretResult+ (addr, SomeInterpretResult ResultStateLogs{..}) = do putTextLn $ "Executed contract " <> pretty addr- case iurOps of- [] -> putTextLn "It didn't return any operations."- _ -> fmt $ nameF "It returned operations" (blockListF iurOps)- putTextLn $- "It returned storage: " <> pretty (untypeValue iurNewStorage) <> "."- let MorleyLogs logs = iurMorleyLogs+ () <- case rslResult of+ T.VPair (ops@T.VList{}, res)+ | _ :: T.Value ('T.TList ops) <- ops+ , T.STOperation <- T.sing @ops \\ T.valueTypeSanity ops+ -> do+ putTextLn $ case T.fromVal @[T.Operation] ops of+ [] -> "It didn't return any operations."+ xs -> fmt $ nameF "It returned operations" (blockListF xs)+ putTextLn $ "It returned: " <> pretty res <> "."+ _ -> putTextLn $ "It returned: " <> pretty rslResult <> "."+ let MorleyLogs logs = rslLogs unless (null logs) $ do putTextLn "And produced logs:" mapM_ putTextLn logs@@ -544,8 +606,7 @@ -- | Resolves 'SomeAddressOrAlias' type to an address. resolveAddress :: SomeAddressOrAlias- -- TODO [#905] or [#889]: Change the return type to `L1Address`- -> ExecutorM Address+ -> ExecutorM L1Address resolveAddress = \case SAOAKindUnspecified aliasText -> do implicitAddrMb <- preuse $ esGState . gsImplicitAddressAliasesL . ix (ImplicitAlias aliasText)@@ -566,12 +627,23 @@ Just addr -> pure addr Nothing -> throwError $ EEUnknownAddressAlias $ SomeAlias alias +-- | Resolves 'ContractAddressOrAlias' type to an address.+resolveContractAddress+ :: ContractAddressOrAlias+ -- TODO [#905] or [#889]: Change the return type to `L1Address`+ -> ExecutorM ContractAddress+resolveContractAddress ct = case ct of+ AddressResolved r -> pure r+ AddressAlias alias -> resolveAddress (SAOAKindSpecified ct) >>= \case+ Constrained result -> case result of+ ContractAddress{} -> pure result+ ImplicitAddress{} -> throwError $ EEUnknownAddressAlias (SomeAlias alias)+ -- | Execute a list of global operations, returning a list of generated events. executeGlobalOperations- :: TypeCheckOptions- -> [ExecutorOp]+ :: [ExecutorOp] -> ExecutorM [EmitOperation]-executeGlobalOperations tcOpts = concatMapM $ \op -> executeMany (#isGlobalOp :! True) [op]+executeGlobalOperations = concatMapM $ \op -> executeMany (#isGlobalOp :! True) [op] where -- Execute a list of operations and additional operations they return, until there are none. executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM [EmitOperation]@@ -586,7 +658,7 @@ executeDelegation isGlobalOp operation executeMany (#isGlobalOp :! False) opsTail TransferOp transferOperation -> do- moreOps <- executeTransfer isGlobalOp tcOpts transferOperation+ moreOps <- executeTransfer isGlobalOp transferOperation executeMany (#isGlobalOp :! False) $ moreOps <> opsTail EmitOp emitOperation -> do liftM2 (:) (executeEmit isGlobalOp emitOperation) $@@ -608,6 +680,11 @@ checkOperationReplay $ OriginateOp origination + tcOpts <- view eeTcOpts++ when (tcStrict tcOpts) $+ liftEither $ first EEDeprecatedType $ checkContractDeprecations ooContract+ opHash <- use esOperationHash gs <- use esGState@@ -685,32 +762,98 @@ checkOperationReplay $ EmitOp op pure op +mkContractEnv+ :: ("balance" :! Mutez)+ -> ("self" :! ContractAddress)+ -> ("sender" :! L1Address)+ -> ("amount" :! Mutez)+ -> ("useOpHash" :! Bool)+ -> ExecutorM ContractEnv+mkContractEnv+ (arg #balance -> ceBalance)+ (arg #self -> ceSelf)+ (arg #sender -> ceSender)+ (arg #amount -> ceAmount)+ (arg #useOpHash -> useOpHash) = do+ ceNow <- view eeNow+ ceLevel <- view eeLevel+ ceMinBlockTime <- view eeMinBlockTime+ ceOperationHash <- if useOpHash then Just <$> use esOperationHash else pure Nothing+ GState+ { gsChainId = ceChainId+ , gsContractAddresses=ceContractsMap+ , gsVotingPowers = ceVotingPowers+ } <- use esGState+ ceMaxSteps <- use esRemainingSteps+ ceSource <- fromMaybe ceSender <$> use esSourceAddress+ pure ContractEnv+ { ceErrorSrcPos = def+ , ceMetaWrapper = id+ , ceContracts = \addr -> pure $ ceContractsMap ^. at addr+ , ..+ }++-- | Typeckeck if necessary and assign big map ids to a parameter.+prepareParameter+ :: forall arg. T.SingI arg+ => ContractAddress+ -> TxParam+ -> "typedParamError" :! (Address -> MismatchError T.T -> ExecutorError)+ -> "untypedParamError" :! (Address -> TcError -> ExecutorError)+ -> ExecutorM (T.Value arg, BigMapCounter)+prepareParameter addr tdParameter+ (arg #typedParamError -> tyParErr)+ (arg #untypedParamError -> unTyParErr)+ = do+ tcOpts <- view eeTcOpts+ gs <- use esGState+ let existingContracts = extractAllContracts gs+ when (tcStrict tcOpts) $ liftEither $ first EEDeprecatedType $ checkSingDeprecations (sing @arg)+ -- If the parameter has already been typechecked, simply check if+ -- its type matches the contract's entrypoint's type.+ -- Otherwise (e.g. if it was parsed from stdin via the CLI),+ -- we need to typecheck the parameter.+ typedParameter <-+ case tdParameter of+ TxTypedParam (typedVal :: T.Value t) ->+ T.castM @t @arg typedVal $+ throwError . tyParErr (MkAddress addr)+ TxUntypedParam untypedVal ->+ liftEither $ first (unTyParErr $ MkAddress addr) $+ typeCheckingWith tcOpts $+ typeVerifyParameter @arg existingContracts untypedVal++ pure $ runState (assignBigMapIds False typedParameter) $ gs ^. gsBigMapCounterL+ -- | Execute a transfer operation.+--+-- Note: we're handling both XTZ and ticket transfers here to avoid code+-- duplication. We assume that if an implicit account sends tickets via+-- 'TxTypedParam', it should be interpreted as @transfer_ticket@ manager+-- operation, and not a regular transfer.+--+-- Note that this only works for 'TxTypedParam', as for ticket transfers between+-- implicit accounts we can't know the exact type of the ticket to transfer if+-- the value is untyped. executeTransfer :: "isGlobalOp" :! Bool- -> TypeCheckOptions -> TransferOperation -> ExecutorM [ExecutorOp]-executeTransfer (arg #isGlobalOp -> isGlobalOp) tcOpts- transferOperation@(- TransferOperation (MkAddress (addr :: KindedAddress kind))- txData@TxData{tdSenderAddress=Constrained senderAddr,..} _) = do+executeTransfer (arg #isGlobalOp -> isGlobalOp) transferOperation+ | TransferOperation addr' txData _ <- transferOperation+ , MkAddress (addr :: KindedAddress kind) <- addr'+ , TxData{tdSenderAddress=Constrained senderAddr,..} <- txData+ = do when isGlobalOp $ beginGlobalOperation - now <- view eeNow- level <- view eeLevel- mbt <- view eeMinBlockTime gs <- use esGState remainingSteps <- use esRemainingSteps sourceAddr <- fromMaybe (tdSenderAddress txData) <$> use esSourceAddress let globalCounter = gsCounter gs let addresses :: Map (KindedAddress kind) (AddressStateFam kind)- addresses = case addr of- ImplicitAddress{} -> gsImplicitAddresses gs- ContractAddress{} -> gsContractAddresses gs- TxRollupAddress{} -> gsTxRollupAddresses gs+ addresses = gs ^. addressesL addr let isZeroTransfer = tdAmount == zeroMutez let senderBalance = lookupBalance senderAddr gs @@ -737,7 +880,7 @@ throwError $ EEWrongParameterType $ MkAddress addr -- Transferring 0 XTZ to a key address is prohibited.- when (isZeroTransfer) $+ when (isZeroTransfer && isUnitParam tdParameter) $ throwError $ EEZeroTransaction $ MkAddress addr mDecreaseSenderBalance <- case senderBalance of@@ -752,6 +895,17 @@ let newBal = balance `unsafeSubMutez` tdAmount pure $ Just $ GSSetBalance senderAddr newBal + let mDecreaseSenderTickets :: Maybe GStateUpdate+ | Just Refl <- isImplicitAddress senderAddr+ -- if an implicit account sends tickets, it can't forge them, so it+ -- must own them.+ = uncurry (GSRemoveTickets senderAddr) <$> sentTickets+ | otherwise = Nothing+ sentTickets :: Maybe (TicketKey, Natural)+ | TxTypedParam v@T.VTicket{} <- tdParameter+ = Just $ toTicketKey v+ | otherwise = Nothing+ let commonFinishup :: Dict (L1AddressKind kind) -- NB: this is a Dict and not a constraint because GHC desugars these@@ -759,13 +913,14 @@ -- site. -> [GStateUpdate] -> [T.Operation]- -> Maybe InterpretResult+ -> Maybe SomeInterpretResult -> RemainingSteps -> ExecutorM [ExecutorOp] commonFinishup Dict otherUpdates sideEffects maybeInterpretRes newRemSteps = do let -- According to the reference implementation, counter is incremented for transfers as well.- updates = (maybe id (:) mDecreaseSenderBalance otherUpdates) ++ [GSIncrementCounter]+ updates = catMaybes [mDecreaseSenderBalance, mDecreaseSenderTickets] <> otherUpdates+ <> [GSIncrementCounter] newGState <- liftEither $ first EEFailedToApplyUpdates $ applyUpdates updates gs @@ -773,24 +928,23 @@ esRemainingSteps .= newRemSteps esSourceAddress .= Just sourceAddr - esLog <>= ExecutorLog updates (maybe mempty (one . (MkAddress addr, )) maybeInterpretRes)+ esLog <>= ExecutorLog updates+ ( maybe+ mempty+ (one . (MkAddress addr,))+ maybeInterpretRes+ ) mapM (convertOp addr) $ sideEffects onlyUpdates :: Dict (L1AddressKind kind) -> [GStateUpdate] -> ExecutorM [ExecutorOp] onlyUpdates dict updates = commonFinishup dict updates [] Nothing remainingSteps case addr of- TxRollupAddress{} ->- -- TODO [#838]: support transaction rollups on the emulator+ SmartRollupAddress{} -> throwError $ EEUnknownContract (MkAddress addr) ImplicitAddress{} -> case addresses ^. at addr of- Nothing -> do- let- transferAmount = tdAmount- addrState = transferAmount- upd = GSAddImplicitAddress addr addrState-- onlyUpdates Dict [upd]+ Nothing -> onlyUpdates Dict . one $+ GSAddImplicitAddress addr tdAmount $ maybeToList sentTickets Just ImplicitState{..} -> do let -- Calculate the account's new balance.@@ -798,13 +952,15 @@ -- Note: `unsafeAddMutez` can't overflow if global state is correct -- (because we can't create money out of nowhere) newBalance = isBalance `unsafeAddMutez` tdAmount- upd = GSSetBalance addr newBalance- onlyUpdates Dict [upd]+ updBalance+ | tdAmount == zeroMutez = Nothing+ | otherwise = Just $ GSSetBalance addr newBalance+ updTickets = uncurry (GSAddTickets addr) <$> sentTickets+ onlyUpdates Dict $ catMaybes [updBalance, updTickets] ContractAddress{} -> case addresses ^. at addr of Nothing -> throwError $ EEUnknownContract (MkAddress addr) Just ContractState{..} -> do let- existingContracts = extractAllContracts gs -- Calculate the contract's new balance. -- -- Note: `unsafeAddMutez` can't overflow if global state is@@ -816,22 +972,9 @@ <- T.mkEntrypointCall epName (T.cParamNotes csContract) & maybe (throwError $ EEUnknownEntrypoint epName) pure - -- If the parameter has already been typechecked, simply check if- -- its type matches the contract's entrypoint's type.- -- Otherwise (e.g. if it was parsed from stdin via the CLI),- -- we need to typecheck the parameter.- typedParameter <-- case tdParameter of- TxTypedParam (typedVal :: T.Value t) ->- T.castM @t @epArg typedVal $- throwError . EEUnexpectedParameterType (MkAddress addr)- TxUntypedParam untypedVal ->- liftEither $ first (EEIllTypedParameter $ MkAddress addr) $- typeCheckingWith tcOpts $- typeVerifyParameter @epArg existingContracts untypedVal-- let bigMapCounter0 = gs ^. gsBigMapCounterL- let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds False typedParameter) bigMapCounter0+ (typedParameterWithIds, bigMapCounter1) <- prepareParameter addr tdParameter+ ! #typedParamError EEUnexpectedParameterType+ ! #untypedParamError EEIllTypedParameter -- 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@@ -840,39 +983,26 @@ -- • Couldn't match type ‘a0’ -- with ‘(InterpretResult, RemainingSteps, [Operation], [GStateUpdate])’ -- ‘a0’ is untouchable inside the constraints: StorageScope st1- () <- when isGlobalOp $- esOperationHash .= mkTransferOperationHash- addr- typedParameterWithIds- tdEntrypoint- tdAmount+ () <- when isGlobalOp $ esOperationHash .= case isImplicitAddress senderAddr of+ Just Refl | Just (tKey, tAmount) <- sentTickets+ -- transfer_ticket is only used when sender is implicit address,+ -- contracts use regular transfer to send tickets.+ -> mkTransferTicketOperationHash tKey tAmount (MkAddress addr) tdEntrypoint+ _ -> mkTransferOperationHash addr typedParameterWithIds tdEntrypoint tdAmount - opHash <- use esOperationHash- let- contractEnv = ContractEnv- { ceNow = now- , ceMaxSteps = remainingSteps- , ceBalance = newBalance- , ceContracts = gsContractAddresses gs- , ceSelf = addr- , ceSource = sourceAddr- , ceSender = Constrained senderAddr- , ceAmount = tdAmount- , ceVotingPowers = gsVotingPowers gs- , ceChainId = gsChainId gs- , ceOperationHash = Just opHash- , ceLevel = level- , ceErrorSrcPos = def- , ceMinBlockTime = mbt- }+ contractEnv <- mkContractEnv+ ! #balance newBalance+ ! #self addr+ ! #sender (Constrained senderAddr)+ ! #amount tdAmount+ ! #useOpHash True - iur@InterpretResult- { iurOps = sideEffects- , iurNewStorage = newValue- , iurNewState = InterpreterState newRemainingSteps globalCounter2 bigMapCounter2- }+ iur@(ResultStateLogs+ { rslResult = extractValOps -> (sideEffects, newValue)+ , rslState = InterpreterState newRemainingSteps globalCounter2 bigMapCounter2+ }) <- liftEither $ first (EEInterpreterFailed (MkAddress addr)) $- handleContractReturn $+ handleReturn $ interpret csContract epc@@ -890,7 +1020,7 @@ | SomeValue newValue == SomeValue csStorage = Nothing | otherwise = Just $ GSSetStorageValue addr newValue updBigMapCounter- | bigMapCounter0 == bigMapCounter2 = Nothing+ | gs ^. gsBigMapCounterL == bigMapCounter2 = Nothing | otherwise = Just $ GSSetBigMapCounter bigMapCounter2 updGlobalCounter | globalCounter == globalCounter2 = Nothing@@ -901,8 +1031,52 @@ , updBigMapCounter , updGlobalCounter ]- commonFinishup Dict updates sideEffects (Just iur) newRemainingSteps+ commonFinishup Dict updates sideEffects (Just $ SomeInterpretResult iur)+ newRemainingSteps +-- | Execute a view.+callView+ :: L1Address+ -> ContractAddress+ -> U.ViewName+ -> TxParam+ -> ExecutorM T.SomeValue+callView sender addr viewName viewArg = do+ ContractState{..} <-+ use (esGState . gsContractAddressesL . at addr)+ >>= maybe (throwError $ EEUnknownContract (MkAddress addr)) pure++ T.SomeView (view'@T.View{} :: T.View viewArg st viewRet)+ <- liftEither $ first (EEViewLookupError (Constrained addr)) $ getViewByName csContract viewName++ (typedParameterWithIds, bigMapCounter1) <- prepareParameter addr viewArg+ ! #typedParamError (\a -> EEViewLookupError a . ViewArgMismatch)+ ! #untypedParamError EEViewArgTcError++ contractEnv <- mkContractEnv+ ! #balance csBalance+ ! #self addr+ ! #sender sender+ ! #amount zeroMutez+ ! #useOpHash False++ counter <- use $ esGState . gsCounterL+ remainingSteps <- use esRemainingSteps++ iur@ResultStateLogs{..} <-+ liftEither $ first (EEInterpreterFailed (MkAddress addr)) $+ handleReturn $ interpretView+ view'+ csStorage+ typedParameterWithIds+ contractEnv+ (InterpreterState remainingSteps counter bigMapCounter1)++ esLog <>= ExecutorLog [] (one . (MkAddress addr, ) $ SomeInterpretResult iur)++ pure . SomeValue $ rslResult++ ---------------------------------------------------------------------------- -- Simple helpers ----------------------------------------------------------------------------@@ -965,8 +1139,13 @@ beginGlobalOperation = esSourceAddress .= Nothing --- | Return True if the param is not Unit.+-- | Return True if the param is not Unit or ticket. badParamToImplicitAccount :: TxParam -> Bool-badParamToImplicitAccount (TxTypedParam T.VUnit) = False-badParamToImplicitAccount (TxUntypedParam U.ValueUnit) = False-badParamToImplicitAccount _ = True+badParamToImplicitAccount (TxTypedParam T.VTicket{}) = False+badParamToImplicitAccount param = not $ isUnitParam param++-- | Return True if parameter is @Unit@.+isUnitParam :: TxParam -> Bool+isUnitParam (TxTypedParam T.VUnit) = True+isUnitParam (TxUntypedParam U.ValueUnit) = True+isUnitParam _ = False
src/Morley/Michelson/Runtime/Dummy.hs view
@@ -19,7 +19,7 @@ import Data.Default (def) -import Morley.Michelson.Interpret (ContractEnv(..), RemainingSteps)+import Morley.Michelson.Interpret (ContractEnv'(..), RemainingSteps) import Morley.Michelson.Runtime.GState (BigMapCounter, ContractState(..), dummyVotingPowers, genesisAddress) import Morley.Michelson.Typed (ParameterScope, StorageScope)@@ -59,12 +59,12 @@ -- | Dummy 'ContractEnv' with some reasonable hardcoded values. You -- can override values you are interested in using record update -- syntax.-dummyContractEnv :: ContractEnv+dummyContractEnv :: Applicative m => ContractEnv' m dummyContractEnv = ContractEnv { ceNow = dummyNow , ceMaxSteps = dummyMaxSteps , ceBalance = [tz|100u|]- , ceContracts = mempty+ , ceContracts = const $ pure Nothing , ceSelf = dummySelf , ceSource = Constrained genesisAddress , ceSender = Constrained genesisAddress@@ -75,6 +75,7 @@ , ceLevel = dummyLevel , ceErrorSrcPos = def , ceMinBlockTime = dummyMinBlockTime+ , ceMetaWrapper = id } -- | 'OriginationOperation' with most data hardcoded to some
src/Morley/Michelson/Runtime/GState.hs view
@@ -9,8 +9,11 @@ ContractState (..) , VotingPowers (..) , ImplicitState (..)+ , TicketKey (..)+ , toTicketKey , isBalanceL , isDelegateL+ , isTicketsL , vpPick , vpTotal , mkVotingPowers@@ -58,11 +61,13 @@ ) where import Control.Lens (at, makeLenses, (?~))-import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.:?), (.=))+import Data.Aeson+ (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey, object, withObject, (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson import Data.Aeson.TH (deriveJSON) import Data.ByteString.Lazy qualified as LBS+import Data.Constraint ((\\)) import Data.Default (def) import Data.Map.Strict qualified as Map import Data.Type.Equality ((:~:)(..))@@ -76,6 +81,7 @@ import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..)) import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped (Contract, Value)+import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Address.Alias import Morley.Tezos.Address.Kinds@@ -85,6 +91,7 @@ import Morley.Util.Bimap (Bimap) import Morley.Util.Bimap qualified as Bimap import Morley.Util.Lens+import Morley.Util.Named import Morley.Util.Peano (ToPeano, type (>)) import Morley.Util.Sing (eqI, eqParamSing, eqParamSing2) import Morley.Util.SizedList qualified as SL@@ -93,6 +100,8 @@ data ImplicitState = ImplicitState { isBalance :: Mutez -- ^ Implicit address balance.+ , isTickets :: HashMap TicketKey Natural+ -- ^ Implicit account's ticket balances. , isDelegate :: Maybe KeyHash -- ^ Delegate, if set. Implicit address can have a delegate set to itself, -- then it's considered "registered delegate" and can be set as delegate for@@ -100,6 +109,23 @@ -- delegate is set to the address itself, it can't be changed. } deriving stock (Show, Eq) +-- | A triple of ticketer, value and type, which uniquely defines a ticket.+newtype TicketKey = TicketKey (Address, U.Value, U.Ty)+ deriving newtype (Eq, Show, ToJSON, FromJSON, FromJSONKey, ToJSONKey)++instance Buildable TicketKey where+ build (TicketKey (addr, val, ty)) =+ "(" +| addr |+ ", " +| val |+ ", " +| ty |+ ")"++instance Hashable TicketKey where+ hashWithSalt s = hashWithSalt s . toJSON++-- | Convert a typed ticket value to 'TicketKey' and amount.+toTicketKey :: forall t. T.HasNoOp t => T.Value ('T.TTicket t) -> (TicketKey, Natural)+toTicketKey (T.VTicket ticketer value amount) =+ (TicketKey (ticketer, T.untypeValue value, T.mkUType $ T.starNotes @t), amount)+ \\ T.valueTypeSanity value+ deriveJSON morleyAesonOptions ''ImplicitState makeLensesWith postfixLFields ''ImplicitState @@ -215,8 +241,8 @@ -- ^ All known implicit addresses and their state (i.e. balance) , gsContractAddresses :: Map ContractAddress ContractState -- ^ All known contract addresses and their state.- , gsTxRollupAddresses :: Map TxRollupAddress ()- -- ^ All known transaction rollup addresses and their state.+ , gsSmartRollupAddresses :: Map SmartRollupAddress ()+ -- ^ All known smart rollup addresses and their state. , gsVotingPowers :: VotingPowers -- ^ Voting power distribution. , gsCounter :: GlobalCounter@@ -298,13 +324,13 @@ GState { gsChainId = dummyChainId , gsImplicitAddresses = Map.fromList- [ (genesis, ImplicitState money Nothing)+ [ (genesis, ImplicitState money mempty Nothing) | let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum ?: error "Number of genesis addresses is 0" , genesis <- toList genesisAddresses ] , gsContractAddresses = Map.empty- , gsTxRollupAddresses = Map.empty+ , gsSmartRollupAddresses = Map.empty , gsVotingPowers = dummyVotingPowers , gsCounter = GlobalCounter 0 , gsBigMapCounter = BigMapCounter 0@@ -344,11 +370,13 @@ -- | Updates that can be applied to 'GState'. data GStateUpdate where- GSAddImplicitAddress :: ImplicitAddress -> Mutez -> GStateUpdate+ GSAddImplicitAddress :: ImplicitAddress -> Mutez -> [(TicketKey, Natural)] -> GStateUpdate GSAddContractAddress :: ContractAddress -> ContractState -> GStateUpdate GSAddContractAddressAlias :: ContractAlias -> ContractAddress -> GStateUpdate GSSetStorageValue :: StorageScope st => ContractAddress -> T.Value st -> GStateUpdate GSSetBalance :: L1AddressKind kind => KindedAddress kind -> Mutez -> GStateUpdate+ GSAddTickets :: ImplicitAddress -> TicketKey -> Natural -> GStateUpdate+ GSRemoveTickets :: ImplicitAddress -> TicketKey -> Natural -> GStateUpdate GSIncrementCounter :: GStateUpdate GSUpdateCounter :: GlobalCounter -> GStateUpdate GSSetBigMapCounter :: BigMapCounter -> GStateUpdate@@ -359,7 +387,7 @@ instance Buildable GStateUpdate where build = \case- GSAddImplicitAddress addr st ->+ GSAddImplicitAddress addr st _ -> "Add implicit address " +| addr |+ " with balance " +| st |+ "" GSAddContractAddress addr st -> "Add contract address " +| addr |+ " with state " +| st |+ ""@@ -378,15 +406,20 @@ "Increment internal big_map counter by: " +| build inc GSSetDelegate addr key -> "Set delegate for " +| addr |+ " to " +| maybe "<nobody>" build key+ GSAddTickets addr key amount ->+ "Add " +| amount |+ " tickets to " +| addr |+ " type " +| key |+ ""+ GSRemoveTickets addr key amount ->+ "Remove " +| amount |+ " tickets from " +| addr |+ " type " +| key |+ "" data GStateUpdateError = GStateAddressExists Address | GStateUnknownAddress Address | GStateStorageNotMatch ContractAddress- | GStateTxRollup TxRollupAddress GStateUpdate | GStateNotDelegate ImplicitAddress | GStateCantDeleteDelegate ImplicitAddress+ | GStateNoBLSDelegate Address KeyHash | GStateAlreadySetDelegate L1Address (Maybe KeyHash)+ | GStateInsufficientTickets ImplicitAddress TicketKey ("needs" :! Natural) ("has" :! Natural) deriving stock (Show) instance Buildable GStateUpdateError where@@ -396,19 +429,24 @@ GStateStorageNotMatch addr -> "Storage type does not match the contract in run-time state\ \ when updating new storage value to address: " <> build addr- GStateTxRollup addr op ->- "Transaction rollup address " +| addr |+ " doesn't support this operation: " +| op |+ "" GStateNotDelegate addr -> "Address " +| addr |+ " is not registered as delegate."+ GStateNoBLSDelegate addr kh ->+ nameF ("Can not set delegate for " +| addr |+ "") $+ nameF "tz4 addresses can't be delegates" $+ build kh GStateCantDeleteDelegate addr -> "Delegate deletion is forbidden for " +| addr |+ "" GStateAlreadySetDelegate addr kh -> "Already set delegate for " +| addr |+ " to " <> maybe "<nothing>" build kh+ GStateInsufficientTickets addr key (arg #needs -> needs) (arg #has -> has) ->+ "Address " +| addr |+ "does not have enough tickets of type " +| key |+ ": has " +| has+ |+ ", needs " +| needs |+ "" -- | Apply 'GStateUpdate' to 'GState'. applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState applyUpdate = \case- GSAddImplicitAddress addr st -> addImplicitAddress addr st+ GSAddImplicitAddress addr st tickets -> addImplicitAddress addr st tickets GSAddContractAddress addr st -> addContractAddress addr st GSAddContractAddressAlias alias addr -> Right . addContractAddressAlias alias addr GSSetStorageValue addr newValue ->@@ -418,16 +456,44 @@ GSUpdateCounter newCounter -> Right . set gsCounterL newCounter GSSetBigMapCounter bmCounter -> Right . set gsBigMapCounterL bmCounter GSSetDelegate addr key -> setDelegate addr key+ GSAddTickets addr key amount -> addTickets addr key amount+ GSRemoveTickets addr key amount -> removeTickets addr key amount +-- | Update ticket balance value associated with given address.+addTickets+ :: ImplicitAddress+ -> TicketKey+ -> Natural+ -> GState+ -> Either GStateUpdateError GState+addTickets addr key num = updateAddressState addr $+ Right . (isTicketsL . at key %~ Just . maybe num (+ num))++-- | Update ticket balance value associated with given address.+removeTickets+ :: ImplicitAddress+ -> TicketKey+ -> Natural+ -> GState+ -> Either GStateUpdateError GState+removeTickets addr key num = updateAddressState addr \st ->+ case st ^. isTicketsL . at key of+ Just n | n >= num -> Right $ st & isTicketsL . at key .~ case n - num of+ 0 -> Nothing+ n' -> Just n'+ n -> Left $ GStateInsufficientTickets addr key ! #needs num ! #has (fromMaybe 0 n)+ -- | Apply a list of 'GStateUpdate's to 'GState'. applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState applyUpdates = flip (foldM (flip applyUpdate)) -- | Add an address if it hasn't been added before.-addImplicitAddress :: ImplicitAddress -> Mutez -> GState -> Either GStateUpdateError GState-addImplicitAddress addr st gs+addImplicitAddress+ :: ImplicitAddress -> Mutez -> [(TicketKey, Natural)] -> GState -> Either GStateUpdateError GState+addImplicitAddress addr st tickets gs | addr `Map.member` (gsImplicitAddresses gs) = Left $ GStateAddressExists (MkAddress addr)- | otherwise = Right $ gs & gsImplicitAddressesL . at addr ?~ ImplicitState st Nothing+ | otherwise = Right $+ gs & gsImplicitAddressesL . at addr ?~ ImplicitState st (fromList tickets) Nothing -- | Add an address if it hasn't been added before. addContractAddress :: ContractAddress -> ContractState -> GState -> Either GStateUpdateError GState@@ -493,6 +559,9 @@ , isRegisteredDelegate addr gs -- implicit addresses that are registered delegates can't change delegates = Left $ GStateCantDeleteDelegate addr+ | Just h@Hash{..} <- newDelegate+ , HashKey KeyTypeBLS <- hTag+ = Left $ GStateNoBLSDelegate (Constrained addr) h | Just kh <- newDelegate , let keyAddr = ImplicitAddress kh , not $ isRegisteredDelegate keyAddr gs@@ -509,8 +578,7 @@ type family AddressStateFam kind where AddressStateFam 'AddressKindImplicit = ImplicitState AddressStateFam 'AddressKindContract = ContractState- -- TODO [#838]: support transaction rollups on the emulator- AddressStateFam 'AddressKindTxRollup = ()+ AddressStateFam 'AddressKindSmartRollup = () updateAddressState :: forall kind. KindedAddress kind@@ -532,7 +600,7 @@ addressesL = \case ImplicitAddress{} -> gsImplicitAddressesL ContractAddress{} -> gsContractAddressesL- TxRollupAddress{} -> gsTxRollupAddressesL+ SmartRollupAddress{} -> gsSmartRollupAddressesL -- | Retrieve all contracts stored in GState extractAllContracts :: GState -> TcOriginatedContracts
src/Morley/Michelson/Runtime/RunCode.hs view
@@ -13,7 +13,7 @@ import Data.Default (def) import Data.Map qualified as Map -import Morley.Michelson.Interpret (ContractEnv(..), InterpretError(..), assignBigMapIds, interpret)+import Morley.Michelson.Interpret import Morley.Michelson.Runtime.Dummy import Morley.Michelson.Runtime.GState import Morley.Michelson.TypeCheck@@ -121,7 +121,7 @@ rcSelf rcDelegate rcVotingPowers- ) = toInterpreterRes $+ ) = fmap (extractValOps . rslResult) . handleReturn $ interpret rcScript rcEntryPoint input storage dummyGlobalCounter bigMapCtr contractEnv where selfState = ContractState@@ -137,14 +137,14 @@ rcSelf ((input, storage), bigMapCtr) = usingState dummyBigMapCounter $ (,) <$> assignBigMapIds False rcInput <*> assignBigMapIds False rcStorage- toInterpreterRes (eith, (_, logs)) = first (InterpretError . (, logs)) eith+ contractMap = Map.insert self selfState rcKnownContracts contractEnv = ContractEnv { ceNow = rcNow , ceBalance = rcBalance , ceSelf = self , ceAmount = rcAmount , ceMinBlockTime = rcMinBlockTime- , ceContracts = Map.insert self selfState rcKnownContracts+ , ceContracts = pure . flip Map.lookup contractMap , ceMaxSteps = dummyMaxSteps , ceSource = rcSource , ceSender = rcSender@@ -153,6 +153,7 @@ , ceLevel = rcLevel , ceErrorSrcPos = def , ceVotingPowers = rcVotingPowers+ , ceMetaWrapper = id } -- | Given an untyped value, possibly containing @big_map@ ids, typecheck it,
src/Morley/Michelson/TypeCheck/Error.hs view
@@ -141,8 +141,6 @@ -- ^ Invalid entrypoint name provided | UnknownContract ContractAddress -- ^ Contract with given address is not originated.- | TxRollupContract TxRollupAddress- -- ^ Provided txr1 address as contract. | EntrypointNotFound T.EpName -- ^ Given entrypoint is not present. | IllegalParamDecl T.ParamEpError@@ -210,8 +208,6 @@ "Not enough items on stack" UnknownContract addr -> "Contract is not registered:" <+> (renderAnyBuildable addr)- TxRollupContract addr ->- "txr1 address can not be used as a contract:" <+> (renderAnyBuildable addr) IllegalEntrypoint err -> renderDoc context err EntrypointNotFound ep -> "No such entrypoint" <+> enclose "`" "`" (renderAnyBuildable ep)@@ -232,7 +228,8 @@ "A big_map with the ID" <+> renderAnyBuildable bigMapId <+> "was found, but it does not have the expected type." <$$> renderDoc context mismatchError -instance Exception TcTypeError+instance Exception TcTypeError where+ displayException = pretty -- | Type check error data TcError' op
src/Morley/Michelson/TypeCheck/Helpers.hs view
@@ -35,11 +35,14 @@ , unaryArithImpl , unaryArithImplAnnotated , withCompareableCheck++ , checkContractDeprecations+ , checkSingDeprecations ) where import Prelude hiding (EQ, GT, LT) -import Control.Monad.Except (MonadError, catchError, throwError)+import Control.Monad.Except (MonadError, catchError, liftEither, throwError) import Data.Constraint (Dict(..), withDict) import Data.Default (def) import Data.Generics (listify)@@ -53,8 +56,8 @@ import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..)) import Morley.Michelson.TypeCheck.Types import Morley.Michelson.Typed- (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM),- Instr(..), SingT(..), T(..), WellTyped, getComparableProofS, requireEq)+ (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, Contract, Contract'(..),+ ExtInstr(COMMENT_ITEM), Instr(..), SingT(..), T(..), WellTyped, getComparableProofS, requireEq) import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Arith (Add, ArithOp(..), EDiv, Mul, Sub, UnaryArithOp(..)) import Morley.Michelson.Typed.Polymorphic@@ -249,17 +252,10 @@ when isStrict $ doCheckBadTypes x doCheckBadTypes :: HST a -> TypeCheckInstr op' () doCheckBadTypes = \case- SNil -> pure ()- (_ :: Sing t, _) ::& _- | ty : _ <- listify isTimeLockTy (demote @t) -> timelockDeprecated ty- _ ::& xs -> doCheckBadTypes xs- isTimeLockTy :: T -> Bool- isTimeLockTy TChest = True- isTimeLockTy TChestKey = True- isTimeLockTy _ = False- timelockDeprecated :: T -> TypeCheckInstr op' a- timelockDeprecated = throwError . TcDeprecatedType- "Timelock mechanism is affected by a vulnerability."+ SNil -> pass+ (s, _) ::& xs -> do+ lift $ liftEither $ checkSingDeprecations s+ doCheckBadTypes xs prependStackTypeComment@@ -276,7 +272,6 @@ isNop :: Instr inp out -> Bool isNop (WithLoc _ i) = isNop i-isNop (FrameInstr _ i) = isNop i isNop (Seq i1 i2) = isNop i1 && isNop i2 isNop (Nested i) = isNop i isNop Nop = True@@ -610,3 +605,20 @@ -> t (SomeTcInstr inp) unaryArithImplAnnotated mkInstr i@((n, _) ::& rs) = do pure $ i :/ mkInstr ::: ((n, Dict) ::& rs)++checkContractDeprecations :: forall cp st op. Contract cp st -> Either (TcError' op) ()+checkContractDeprecations Contract{} =+ checkSingDeprecations (sing @cp) >> checkSingDeprecations (sing @st)++checkSingDeprecations :: SingT t -> Either (TcError' op) ()+checkSingDeprecations s+ | ty : _ <- listify isTimeLockTy (fromSing s) = timelockDeprecated ty+ | otherwise = pass+ where+ isTimeLockTy :: T -> Bool+ isTimeLockTy TChest = True+ isTimeLockTy TChestKey = True+ isTimeLockTy _ = False+ timelockDeprecated :: T -> Either (TcError' op') a+ timelockDeprecated = throwError . TcDeprecatedType+ "Timelock mechanism is affected by a vulnerability."
src/Morley/Michelson/TypeCheck/Instr.hs view
@@ -58,17 +58,17 @@ import Prelude hiding (EQ, GT, LT) import Control.Monad.Except (MonadError, catchError, liftEither, throwError)+import Data.Coerce (coerce) import Data.Constraint ((\\))-import Data.Default (def)+import Data.Default (Default(def)) import Data.Generics (everything, mkQ)-import Data.Sequence ((|>))-import Data.Sequence qualified as Seq import Data.Singletons (Sing, SomeSing(..), demote, withSingI) import Data.Type.Equality (TestEquality(..)) import Data.Typeable ((:~:)(..)) import Fmt (pretty) import Morley.Michelson.ErrorPos (ErrorSrcPos)+import Morley.Michelson.Internal.ViewsSet as VS import Morley.Michelson.TypeCheck.Error import Morley.Michelson.TypeCheck.Ext import Morley.Michelson.TypeCheck.Helpers@@ -80,6 +80,7 @@ import Morley.Michelson.TypeCheck.Value import Morley.Michelson.Typed hiding (Branch(..)) import Morley.Michelson.Typed.Contract (giveNotInView)+import Morley.Michelson.Typed.Instr.Constraints import Morley.Util.MismatchError import Morley.Util.Peano@@ -169,7 +170,7 @@ pure $ IllTypedSeq err [NonTypedInstr $ liftInstr v] doTypeCheckContract'- :: IsInstrOp op+ :: forall op. IsInstrOp op => TcInstrBase op -> U.Contract' op -> TypeCheck op SomeContract@@ -198,11 +199,12 @@ tcsEither onFailedCodeTypeCheck pure codeRes -- typecheck views- views <- typeCheckViews' tcOp- uContract{ U.contractCode = [someInstrToOp instr], U.contractViews = [] }+ cViews <- typeCheckViews' tcOp+ uContract{ U.contractCode = [someInstrToOp instr], U.contractViews = def } storageNote uViews - handleError (onFailedFullTypeCheck [someInstrToOp instr] (zipWith someViewToOp uViews views)) $ do+ let tcViews = coerce $ someViewToOp @_ @op <$> coerce @_ @(ViewsSetF (SomeView st)) cViews+ handleError (onFailedFullTypeCheck [someInstrToOp instr] tcViews) $ do -- match contract code with contract signature, construct contract let cStoreNotes = storageNote cParamNotes <-@@ -210,8 +212,6 @@ mkParamNotes paramNote rootAnn `onFirst` (TcContractError "invalid parameter declaration: " . Just . IllegalParamDecl) let cEntriesOrder = entriesOrder- cViews <- liftEither $- mkViewsSet views `onFirst` \e -> TcContractError (pretty e) Nothing case instrOut of instr' ::: out -> liftEither $ do case eqHST1 @('TPair ('TList 'TOperation) st) out of@@ -223,7 +223,7 @@ pure $ SomeContract Contract{ cCode = ContractCode instr', .. } where- hasTypeError :: forall (t :: T) a op. SingI t => Text -> BadTypeForScope -> TypeCheck op a+ hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck op a hasTypeError name reason = throwError $ TcContractError ("contract " <> name <> " type error") $ Just $ UnsupportedTypeForScope (demote @t) reason@@ -237,11 +237,11 @@ , contractStorage = mStorage , contractCode = ops , entriesOrder = entriesOrder- , contractViews = []+ , contractViews = def } else err - onFailedFullTypeCheck :: [TypeCheckedOp op] -> [U.View' (TypeCheckedOp op)] -> TcError' op -> TypeCheck op a+ onFailedFullTypeCheck :: [TypeCheckedOp op] -> U.ViewsSet (TypeCheckedOp op) -> TcError' op -> TypeCheck op a onFailedFullTypeCheck ops views err = do verbose <- asks' tcVerbose throwError if verbose@@ -336,37 +336,43 @@ => TcInstrBase op -> U.Contract' (TypeCheckedOp op) -> Notes st- -> [U.View' op]- -> TypeCheck op [SomeView st]-typeCheckViews' doTypeCheckOp tcContract storageNote cViews =- let myfoldM l acc f = foldM f acc l in- fmap (map snd . toList) $ myfoldM cViews (Seq.Empty :: Seq (U.View' op, SomeView st))- \processedViews uView -> do- resView <- typeCheckView' doTypeCheckOp storageNote uView- pure $ processedViews |> (uView, resView)- `catchError` \case- TcIncompletelyTypedView err view' ->- let tcViews = map (uncurry someViewToOp) processedViews- in onFailedViewsTypeCheck tcViews view' err- err -> throwError err+ -> U.ViewsSet op+ -> TypeCheck op (ViewsSet st)+typeCheckViews' doTypeCheckOp tcContract storageNote cViews = coerce $+ coerce cViews & runningTotalMapM \processedViews name uView -> do+ typeCheckView' doTypeCheckOp storageNote uView+ `catchError` \case+ TcIncompletelyTypedView err view' ->+ let tcViews = someViewToOp <$> processedViews+ in onFailedViewsTypeCheck (coerce $ unsafeInsert name view' tcViews) err+ err -> throwError err where- onFailedViewsTypeCheck- :: Seq (U.View' (TypeCheckedOp op)) -> U.View' (TypeCheckedOp op) -> TcError' op -> TypeCheck op a- onFailedViewsTypeCheck processedViews v err = do+ -- NB: since we only walk one map and build another one using the same keys,+ -- this is actually safe, but be mindful of this when changing this code.+ unsafeInsert :: ViewName -> a -> ViewsSetF a -> ViewsSetF a+ unsafeInsert = unsafe ... VS.addViewToSet . const++ onFailedViewsTypeCheck :: U.ViewsSet (TypeCheckedOp op) -> TcError' op -> TypeCheck op a+ onFailedViewsTypeCheck processedViews err = do verbose <- asks' tcVerbose throwError if verbose then TcIncompletelyTyped err tcContract- { U.contractViews = toList (processedViews |> v)+ { U.contractViews = processedViews } else err + runningTotalMapM :: Monad m => (ViewsSetF b -> ViewName -> a -> m b) -> ViewsSetF a -> m (ViewsSetF b)+ runningTotalMapM f views = toPairs views & flip foldM def \acc (k, el) -> do+ newEl <- f acc k el+ pure $ unsafeInsert k newEl acc+ typeCheckViews :: WellTyped st => U.Contract' (TypeCheckedOp U.ExpandedOp) -> Notes st- -> [U.View]- -> TypeCheck U.ExpandedOp [SomeView st]-typeCheckViews = typeCheckViews' typeCheckExpandedOp+ -> U.ViewsSet U.ExpandedOp+ -> TypeCheck U.ExpandedOp (ViewsSet st)+typeCheckViews = coerce $ typeCheckViews' typeCheckExpandedOp -- | Function @typeCheckList@ converts list of Michelson instructions -- given in representation from @Morley.Michelson.Type@ module to representation@@ -1304,15 +1310,21 @@ (U.LSL vn, (STNat, _) ::& (STNat, _) ::& _) -> workOnInstr uInstr $ arithImpl @Lsl AnnLSL inp vn uInstr+ (U.LSL vn, (STBytes, _) ::&+ (STNat, _) ::& _) -> workOnInstr uInstr $+ arithImpl @Lsl AnnLSL inp vn uInstr (U.LSL _, _ ::& _ ::& _) ->- failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []+ failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| [("bytes" :| ["nat"])] (U.LSL _, _) -> notEnoughItemsOnStack (U.LSR vn, (STNat, _) ::& (STNat, _) ::& _) -> workOnInstr uInstr $ arithImpl @Lsr AnnLSR inp vn uInstr+ (U.LSR vn, (STBytes, _) ::&+ (STNat, _) ::& _) -> workOnInstr uInstr $+ arithImpl @Lsr AnnLSR inp vn uInstr (U.LSR _, _ ::& _ ::& _) ->- failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| []+ failWithErr $ UnexpectedType $ ("nat" :| ["nat"]) :| [("bytes" :| ["nat"])] (U.LSR _, _) -> notEnoughItemsOnStack (U.OR vn, (STBool, _) ::&@@ -1321,10 +1333,14 @@ (U.OR vn, (STNat, _) ::& (STNat, _) ::& _) -> workOnInstr uInstr $ arithImpl @Or AnnOR inp vn uInstr+ (U.OR vn, (STBytes, _) ::&+ (STBytes, _) ::& _) -> workOnInstr uInstr $+ arithImpl @Or AnnOR inp vn uInstr (U.OR _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("bool" :| ["bool"]) :| [ ("nat" :| ["nat"])+ , ("bytes" :| ["bytes"]) ] (U.OR _, _) -> notEnoughItemsOnStack @@ -1337,11 +1353,15 @@ (U.AND vn, (STBool, _) ::& (STBool, _) ::& _) -> workOnInstr uInstr $ arithImpl @And AnnAND inp vn uInstr+ (U.AND vn, (STBytes, _) ::&+ (STBytes, _) ::& _) -> workOnInstr uInstr $+ arithImpl @And AnnAND inp vn uInstr (U.AND _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("int" :| ["nat"]) :| [ ("nat" :| ["nat"]) , ("bool" :| ["bool"])+ , ("bytes" :| ["bytes"]) ] (U.AND _, _) -> notEnoughItemsOnStack @@ -1351,10 +1371,14 @@ (U.XOR vn, (STNat, _) ::& (STNat, _) ::& _) -> workOnInstr uInstr $ arithImpl @Xor AnnXOR inp vn uInstr+ (U.XOR vn, (STBytes, _) ::&+ (STBytes, _) ::& _) -> workOnInstr uInstr $+ arithImpl @Xor AnnXOR inp vn uInstr (U.XOR _, _ ::& _ ::& _) -> failWithErr $ UnexpectedType $ ("bool" :| ["bool"]) :| [ ("nat" :| ["nat"])+ , ("bytes" :| ["bytes"]) ] (U.XOR _, _) -> notEnoughItemsOnStack @@ -1364,11 +1388,14 @@ pure $ unaryArithImplAnnotated @Not (AnnNOT (Anns1 vn)) inp vn (U.NOT vn, (STInt, _) ::& _) -> workOnInstr uInstr $ pure $ unaryArithImplAnnotated @Not (AnnNOT (Anns1 vn)) inp vn+ (U.NOT vn, (STBytes, _) ::& _) -> workOnInstr uInstr $+ pure $ unaryArithImplAnnotated @Not (AnnNOT (Anns1 vn)) inp vn (U.NOT _, _ ::& _) -> failWithErr $ UnexpectedType $ ("nat" :| []) :| [ ("bool" :| []) , ("int" :| [])+ , ("bytes" :| []) ] (U.NOT _, SNil) -> notEnoughItemsOnStack @@ -1429,11 +1456,27 @@ (U.INT vn, (STNat{}, _) ::& rs) -> workOnInstr uInstr $ pure $ inp :/ AnnINT (Anns1 vn) ::: ((sing, Dict) ::& rs)+ (U.INT vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $+ pure $ inp :/ AnnINT (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.INT vn, (STBls12381Fr{}, _) ::& rs) -> workOnInstr uInstr $ pure $ inp :/ AnnINT (Anns1 vn) ::: ((sing, Dict) ::& rs) (U.INT _, _ ::& _) ->- failWithErr $ UnexpectedType $ ("nat" :| []) :| ["bls12_381_fr" :| []]+ failWithErr $ UnexpectedType $ one "nat" :| [one "bytes", one "bls12_381_fr"] (U.INT _, SNil) -> notEnoughItemsOnStack++ (U.NAT vn, (STBytes{}, _) ::& rs) -> workOnInstr uInstr $+ pure $ inp :/ AnnNAT (Anns1 vn) ::: ((sing, Dict) ::& rs)+ (U.NAT _, _ ::& _) ->+ failWithErr $ UnexpectedType $ ("bytes" :| []) :| []+ (U.NAT _, SNil) -> notEnoughItemsOnStack++ (U.BYTES vn, (STInt{}, _) ::& rs) -> workOnInstr uInstr $+ pure $ inp :/ AnnBYTES (Anns1 vn) ::: ((sing, Dict) ::& rs)+ (U.BYTES vn, (STNat{}, _) ::& rs) -> workOnInstr uInstr $+ pure $ inp :/ AnnBYTES (Anns1 vn) ::: ((sing, Dict) ::& rs)+ (U.BYTES _, _ ::& _) ->+ failWithErr $ UnexpectedType $ ("int" :| []) :| [ "nat" :| [] ]+ (U.BYTES _, SNil) -> notEnoughItemsOnStack (U.VIEW vn name (AsUType (retNotes :: Notes ret)), _ ::& (STAddress{}, _) ::& rs) -> workOnInstr uInstr $
src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs view
@@ -16,6 +16,7 @@ import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces) import Morley.Michelson.TypeCheck.Types (HST(..), SomeTcInstr(..), SomeTcInstrOut(..)) import Morley.Michelson.Typed.Aliases+import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Convert (instrToOps) import Morley.Michelson.Typed.Instr (Instr, castInstr) import Morley.Michelson.Typed.View (SomeView'(..), View'(..))@@ -65,11 +66,14 @@ go (i ::: _) = WellTypedOp i go (AnyOutInstr i) = WellTypedOp (i @'[]) --- | Makes a view with well-typed code, taking the untyped and typechecked view.-someViewToOp :: U.View' op -> SomeView st -> U.View' (TypeCheckedOp op)-someViewToOp U.View{..} (SomeView View{..}) = U.View+-- | Makes takes a typed view and converts it into an untyped one with+-- typechecked code.+someViewToOp :: SomeView st -> U.View' (TypeCheckedOp op)+someViewToOp (SomeView View{..}) = U.View { U.viewCode = [WellTypedOp vCode]- , ..+ , U.viewName = vName+ , U.viewArgument = mkUType vArgument+ , U.viewReturn = mkUType vReturn } $(deriveGADTNFData ''TypeCheckedOp)
src/Morley/Michelson/TypeCheck/Value.hs view
@@ -102,13 +102,6 @@ case parseKeyHashRaw (U.unInternalByteString b) of Right kHash -> pure $ VKeyHash kHash Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)- (v@(U.ValueString s), t@STTxRollupL2Address) -> case parseHash (unMText s) of- Right kHash -> pure $ VTxRollupL2Address $ TxRollupL2Address kHash- Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)- (v@(U.ValueBytes b), t@STTxRollupL2Address) ->- case parseKeyHashL2Raw (U.unInternalByteString b) of- Right kHash -> pure $ VTxRollupL2Address $ TxRollupL2Address kHash- Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err) (U.ValueInt i, STBls12381Fr) -> pure $ VBls12381Fr (fromIntegralOverflowing @Integer @Bls12381Fr i) (v@(U.ValueBytes b), t@STBls12381Fr) ->@@ -363,9 +356,16 @@ "Unsupported type in type argument of 'contract' type" instrPos $ Just $ UnsupportedTypeForScope (fromSing pc) reason case addr of- ImplicitAddress _ -> do- Refl <- ensureTypeMatches @'T.TUnit- pure $ VContract (MkAddress addr) T.sepcPrimitive+ ImplicitAddress _ -> case pc of+ STUnit -> pure $ VContract (MkAddress addr) T.sepcPrimitive+ STTicket _ -> do+ Dict <- liftEither+ $ first unsupportedType+ $ withSingI pc $ T.checkScope @(T.ParameterScope cp)+ pure $ VContract (MkAddress addr) T.sepcPrimitive+ _ -> throwError $+ TcFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos $ Just $+ UnexpectedType (one "unit" :| [one "ticket 'a"]) ContractAddress ca -> case mOriginatedContracts of Nothing -> liftEither . Left $ unsupportedType T.BtHasContract Just originatedContracts -> case M.lookup ca originatedContracts of@@ -381,9 +381,13 @@ Nothing -> throwError $ TcFailedOnValue cv (demote @ty) "Contract literal unknown" instrPos (Just $ UnknownContract addr)- TxRollupAddress _ ->- throwError $ TcFailedOnValue cv (demote @ty) "txr1 address passed as contract"- instrPos (Just $ TxRollupContract addr)+ SmartRollupAddress _ -> do+ -- TODO [#932]: Check that argument type matches+ Dict <- liftEither $+ first (TcFailedOnValue cv (demote @ty) "Bad parameter type" instrPos .+ Just . UnsupportedTypeForScope (fromSing pc)) $+ withSingI pc $ T.checkScope @(T.ParameterScope cp)+ pure $ VContract (MkAddress addr) $ T.SomeEpc T.unsafeEpcCallRoot withComparable :: forall a (t :: T.T) ty op. Sing a
src/Morley/Michelson/Typed/Annotation.hs view
@@ -87,7 +87,6 @@ NTChest :: TypeAnn -> Notes 'TChest NTChestKey :: TypeAnn -> Notes 'TChestKey NTNever :: TypeAnn -> Notes 'TNever- NTTxRollupL2Address :: TypeAnn -> Notes 'TTxRollupL2Address NTSaplingState :: forall (n :: Peano.Peano). TypeAnn -> Sing n -> Notes ('TSaplingState n) NTSaplingTransaction :: forall (n :: Peano.Peano). TypeAnn -> Sing n -> Notes ('TSaplingTransaction n) @@ -128,7 +127,6 @@ NTOperation _ -> sing NTChest _ -> sing NTChestKey _ -> sing- NTTxRollupL2Address _ -> sing NTNever _ -> sing NTSaplingState _ s -> STSaplingState s NTSaplingTransaction _ s -> STSaplingTransaction s@@ -169,7 +167,6 @@ NTOperation tn -> Un.Ty Un.TOperation tn NTChest tn -> Un.Ty Un.TChest tn NTChestKey tn -> Un.Ty Un.TChestKey tn- NTTxRollupL2Address tn -> Un.Ty Un.TTxRollupL2Address tn NTNever tn -> Un.Ty Un.TNever tn NTSaplingState tn s -> Un.Ty (Un.TSaplingState (singPeanoVal s)) tn NTSaplingTransaction tn s -> Un.Ty (Un.TSaplingTransaction (singPeanoVal s)) tn@@ -204,7 +201,6 @@ STAddress -> NTAddress noAnn STKey -> NTKey noAnn STUnit -> NTUnit noAnn- STTxRollupL2Address -> NTTxRollupL2Address noAnn STNever -> NTNever noAnn STSaplingState s -> NTSaplingState noAnn s STSaplingTransaction s -> NTSaplingTransaction noAnn s@@ -261,7 +257,6 @@ NTChainId _ -> NTChainId nt NTChest _ -> NTChest nt NTChestKey _ -> NTChestKey nt- NTTxRollupL2Address _ -> NTTxRollupL2Address nt NTNever _ -> NTNever nt NTSaplingState _ n -> NTSaplingState nt n NTSaplingTransaction _ n -> NTSaplingTransaction nt n
src/Morley/Michelson/Typed/Arith.hs view
@@ -8,6 +8,8 @@ ( ArithOp (..) , UnaryArithOp (..) , ToIntArithOp (..)+ , ToBytesArithOp (..)+ , evalToNatOp , ArithError (..) , ShiftArithErrorType (..) , MutezArithErrorType (..)@@ -37,7 +39,10 @@ , Bls12381MulBadOrder ) where -import Data.Bits (complement, shift, (.&.), (.|.))+import Crypto.Number.Basic (numBits)+import Crypto.Number.Serialize (i2osp, os2ip)+import Data.Bits (complement, setBit, shift, zeroBits, (.&.), (.|.))+import Data.ByteString qualified as BS import Data.Constraint (Bottom(..), Dict(..)) import Fmt (Buildable(build), (+|), (|+)) import Type.Errors (DelayError)@@ -117,6 +122,10 @@ class ToIntArithOp (n :: T) where evalToIntOp :: Value' instr n -> Value' instr 'TInt +-- | Class for conversions to bytes.+class ToBytesArithOp (n :: T) where+ evalToBytesOp :: Value' instr n -> Value' instr 'TBytes+ data Add data Sub data SubMutez@@ -329,6 +338,20 @@ type UnaryArithRes Neg 'TBls12381G2 = 'TBls12381G2 evalUnaryArithOp _ (VBls12381G2 i) = VBls12381G2 (BLS.negate i) +bitwiseWithByteStringsEnd+ :: (Int -> Int -> Int) -- ^ Length comparator+ -> (Word8 -> Word8 -> Word8) -- ^ Zipper+ -> ByteString -> ByteString -> ByteString+bitwiseWithByteStringsEnd comp op i j = BS.pack $ BS.zipWith op i' j'+ -- TODO [#919]: use packZipWith and takeEnd+ where+ resultLen = comp lenI lenJ+ lenI = length i+ lenJ = length j+ normalize len = (BS.replicate (resultLen - len) 0 <>) . BS.drop (len - resultLen)+ i' = normalize lenI i+ j' = normalize lenJ j+ instance ArithOp Or 'TNat 'TNat where type ArithRes Or 'TNat 'TNat = 'TNat evalOp _ (VNat i) (VNat j) = Right $ VNat (i .|. j)@@ -337,6 +360,10 @@ type ArithRes Or 'TBool 'TBool = 'TBool evalOp _ (VBool i) (VBool j) = Right $ VBool (i .|. j) commutativityProof = Just Dict+instance ArithOp Or 'TBytes 'TBytes where+ type ArithRes Or 'TBytes 'TBytes = 'TBytes+ evalOp _ (VBytes i) (VBytes j) = Right $ VBytes $ bitwiseWithByteStringsEnd max (.|.) i j+ commutativityProof = Just Dict instance ArithOp And 'TInt 'TNat where type ArithRes And 'TInt 'TNat = 'TNat@@ -349,6 +376,10 @@ type ArithRes And 'TBool 'TBool = 'TBool evalOp _ (VBool i) (VBool j) = Right $ VBool (i .&. j) commutativityProof = Just Dict+instance ArithOp And 'TBytes 'TBytes where+ type ArithRes And 'TBytes 'TBytes = 'TBytes+ evalOp _ (VBytes i) (VBytes j) = Right $ VBytes $ bitwiseWithByteStringsEnd min (.&.) i j+ commutativityProof = Just Dict instance ArithOp Xor 'TNat 'TNat where type ArithRes Xor 'TNat 'TNat = 'TNat@@ -358,6 +389,10 @@ type ArithRes Xor 'TBool 'TBool = 'TBool evalOp _ (VBool i) (VBool j) = Right $ VBool (i `xor` j) commutativityProof = Just Dict+instance ArithOp Xor 'TBytes 'TBytes where+ type ArithRes Xor 'TBytes 'TBytes = 'TBytes+ evalOp _ (VBytes i) (VBytes j) = Right $ VBytes $ bitwiseWithByteStringsEnd max xor i j+ commutativityProof = Just Dict instance ArithOp Lsl 'TNat 'TNat where type ArithRes Lsl 'TNat 'TNat = 'TNat@@ -365,6 +400,16 @@ if j > 256 then Left $ ShiftArithError LslOverflow n m else Right $ VNat (fromInteger $ shift (toInteger i) (Unsafe.fromIntegral @Natural @Int j))+instance ArithOp Lsl 'TBytes 'TNat where+ type ArithRes Lsl 'TBytes 'TNat = 'TBytes+ evalOp _ n@(VBytes i) m@(VNat j) =+ if j > 64000+ then Left $ ShiftArithError LslOverflow n m+ else Right $ VBytes $+ let -- according to the docs, the result is left-padded to this number of bytes+ len = length i + Unsafe.fromIntegral @Natural @Int ((j + 7) `div` 8)+ bs = i2osp $ shift (os2ip i) (Unsafe.fromIntegral @Natural @Int j)+ in BS.replicate (len - length bs) 0 <> bs instance ArithOp Lsr 'TNat 'TNat where type ArithRes Lsr 'TNat 'TNat = 'TNat@@ -372,6 +417,22 @@ if j > 256 then Left $ ShiftArithError LsrUnderflow n m else Right $ VNat (fromInteger $ shift (toInteger i) (-(Unsafe.fromIntegral @Natural @Int j)))+instance ArithOp Lsr 'TBytes 'TNat where+ type ArithRes Lsr 'TBytes 'TNat = 'TBytes+ evalOp _ (VBytes i) (VNat j)+ -- Michelson docs claim there's a limit of 256, but actually there isn't.+ -- https://gitlab.com/tezos/tezos/-/issues/5018+ -- Very large shifts just return empty byte string+ -- https://gitlab.com/tezos/tezos/-/blob/b2a49caf2e6d4b34c4fd226996d3637e19397401/src/proto_alpha/lib_protocol/script_bytes.ml#L48+ | j > fromIntegralOverflowing @Int @Natural maxBound = Right $ VBytes mempty+ | otherwise = Right $ VBytes $+ let k = Unsafe.fromIntegral @Natural @Int j -- safe, we just checked bounds above+ -- empirical number of bytes to match octez impl+ -- this is inverse to LSL in some sense+ len = length i - (k `div` 8)+ bs = i2osp $ shift (os2ip i) (-k)+ finalLenDiff = len - length bs+ in BS.replicate finalLenDiff 0 <> BS.drop (-finalLenDiff) bs instance UnaryArithOp Not 'TInt where type UnaryArithRes Not 'TInt = 'TInt@@ -382,6 +443,9 @@ instance UnaryArithOp Not 'TBool where type UnaryArithRes Not 'TBool = 'TBool evalUnaryArithOp _ (VBool i) = VBool (not i)+instance UnaryArithOp Not 'TBytes where+ type UnaryArithRes Not 'TBytes = 'TBytes+ evalUnaryArithOp _ (VBytes i) = VBytes (BS.map complement i) -- | Implementation for @COMPARE@ instruction. compareOp :: Comparable t => Value' i t -> Value' i t -> Integer@@ -423,6 +487,45 @@ instance ToIntArithOp 'TBls12381Fr where evalToIntOp (VBls12381Fr i) = VInt (toInteger i)++instance ToIntArithOp 'TBytes where+ evalToIntOp (VBytes i) = VInt $ case BS.uncons i of+ Nothing -> 0+ Just (msb, _)+ -- positive, msbit not set+ | msb .&. 0x80 == 0 -> x+ -- negative+ | otherwise -> x - comp+ where+ x = os2ip i+ nbytes = length i+ comp = setBit zeroBits (nbytes * 8)++instance ToBytesArithOp 'TNat where+ evalToBytesOp (VNat i)+ | 0 <- i = VBytes mempty+ | otherwise = VBytes $ i2osp $ toInteger i++instance ToBytesArithOp 'TInt where+ evalToBytesOp (VInt i)+ | 0 <- i = VBytes mempty+ | otherwise = VBytes $ BS.replicate (nbytes - length bs) 0 <> bs+ where+ x = abs i+ nbits = case numBits x of+ n | i < 0, setBit zeroBits (n - 1) == x+ -- exactly 0b10…0, by convention it's a negative, so doesn't need an extra bit+ -> n+ | otherwise -> n + 1 -- extra bit for sign.+ nbytes = (nbits + 7) `div` 8+ bs+ | i >= 0 = i2osp i+ | otherwise = i2osp $ setBit zeroBits (nbytes * 8) - x -- two's complement++evalToNatOp :: Value' instr 'TBytes -> Value' instr 'TNat+evalToNatOp (VBytes a)+ | null a = VNat 0+ | otherwise = VNat . Unsafe.fromIntegral @Integer @Natural $ os2ip a instance Buildable ShiftArithErrorType where build = \case
src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs view
@@ -17,7 +17,6 @@ hasAnns = \case WithLoc -> DoesNotHaveAnns Meta -> DoesNotHaveAnns- FrameInstr -> DoesNotHaveAnns DocGroup -> DoesNotHaveAnns Nop -> DoesNotHaveAnns Ext -> DoesNotHaveAnns@@ -100,6 +99,8 @@ AnnLE -> DoesHaveStandardAnns AnnGE -> DoesHaveStandardAnns AnnINT -> DoesHaveStandardAnns+ AnnNAT -> DoesHaveStandardAnns+ AnnBYTES -> DoesHaveStandardAnns AnnVIEW -> DoesHaveStandardAnns AnnSELF -> DoesHaveStandardAnns AnnCONTRACT -> DoesHaveStandardAnns
src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs view
@@ -20,7 +20,6 @@ -------------------- WithLoc -> FailingNormal Meta -> FailingNormal- FrameInstr -> FailingNormal DocGroup -> FailingNormal Nop -> FailingNormal Ext -> FailingNormal@@ -100,6 +99,8 @@ AnnLE -> FailingNormal AnnGE -> FailingNormal AnnINT -> FailingNormal+ AnnNAT -> FailingNormal+ AnnBYTES -> FailingNormal AnnVIEW -> FailingNormal AnnSELF -> FailingNormal AnnCONTRACT -> FailingNormal
src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs view
@@ -16,7 +16,6 @@ isMichelson = \case WithLoc -> Phantom Meta -> Phantom- FrameInstr -> Phantom DocGroup -> Phantom Nop -> Additional Ext -> Additional@@ -99,6 +98,8 @@ AnnLE -> FromMichelson AnnGE -> FromMichelson AnnINT -> FromMichelson+ AnnNAT -> FromMichelson+ AnnBYTES -> FromMichelson AnnVIEW -> FromMichelson AnnSELF -> FromMichelson AnnCONTRACT -> FromMichelson
src/Morley/Michelson/Typed/Contract.hs view
@@ -20,11 +20,15 @@ , mapContractCode , mapContractCodeBlock , mapContractViewBlocks+ , mapContractCodeM+ , mapContractCodeBlockM+ , mapContractViewBlocksM , mapEntriesOrdered ) where import Data.Constraint (Dict(..)) import Data.Default (Default(..))+import Data.Map qualified as Map import GHC.TypeLits (TypeError, pattern Text) import Unsafe.Coerce (unsafeCoerce) @@ -33,7 +37,8 @@ import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T (T(..)) import Morley.Michelson.Typed.View-import Morley.Michelson.Untyped.Contract (EntriesOrder, entriesOrderToInt)+import Morley.Michelson.Untyped.Contract (EntriesOrder)+import Morley.Michelson.Untyped.Contract qualified as U type ContractInp1 param st = 'TPair param st type ContractInp param st = '[ ContractInp1 param st ]@@ -130,28 +135,53 @@ -> instr (ContractInp cp st) (ContractOut st)) -> Contract' instr cp st -> Contract' instr cp st-mapContractCodeBlock f contract = contract { cCode =- case cCode contract of- ContractCode c -> ContractCode $ f c }+mapContractCodeBlock f = runIdentity . mapContractCodeBlockM (pure . f) +-- | Transform contract @code@ block, monadic version.+--+-- To map e.g. views too, see 'mapContractCodeM'.+mapContractCodeBlockM+ :: Monad m+ => (instr (ContractInp cp st) (ContractOut st)+ -> m (instr (ContractInp cp st) (ContractOut st)))+ -> Contract' instr cp st+ -> m (Contract' instr cp st)+mapContractCodeBlockM f contract = do+ code <- case cCode contract of ContractCode c -> ContractCode <$> f c+ pure contract { cCode = code }+ mapContractViewBlocks :: (forall arg ret. ViewCode' instr arg st ret -> ViewCode' instr arg st ret) -> Contract' instr cp st -> Contract' instr cp st-mapContractViewBlocks f contract = contract- { cViews = UnsafeViewsSet $- unViewsSet (cViews contract) <&> \(SomeView v) -> SomeView v{ vCode = f $ vCode v }- }+mapContractViewBlocks f = runIdentity . mapContractViewBlocksM (pure . f) +mapContractViewBlocksM+ :: Monad m+ => (forall arg ret. ViewCode' instr arg st ret -> m (ViewCode' instr arg st ret))+ -> Contract' instr cp st+ -> m (Contract' instr cp st)+mapContractViewBlocksM f contract = do+ views <- UnsafeViewsSet <$> forM (unViewsSet (cViews contract)) \(SomeView v) -> do+ code <- f $ vCode v+ pure $ SomeView v{ vCode = code }+ pure contract{ cViews = views }+ -- | Map all the blocks with some code in the contract. mapContractCode :: (forall i o. instr i o -> instr i o) -> Contract' instr cp st -> Contract' instr cp st-mapContractCode f =- mapContractCodeBlock f .- mapContractViewBlocks f+mapContractCode f = runIdentity . mapContractCodeM (pure . f) +-- | Map all the blocks with some code in the contract, monadic version.+mapContractCodeM+ :: Monad m+ => (forall i o. instr i o -> m (instr i o))+ -> Contract' instr cp st+ -> m (Contract' instr cp st)+mapContractCodeM f = mapContractCodeBlockM f <=< mapContractViewBlocksM f+ -- | Map each typed contract fields by the given function and sort the output -- based on the 'EntriesOrder'. mapEntriesOrdered@@ -159,13 +189,16 @@ -> (ParamNotes cp -> a) -> (Notes st -> a) -> (ContractCode' instr cp st -> a)+ -> (forall arg ret. View' instr arg st ret -> a) -> [a]-mapEntriesOrdered Contract{..} fParam fStorage fCode =- fmap snd- $ sortWith fst- [ (paramPos, fParam cParamNotes)- , (storagePos, fStorage cStoreNotes)- , (codePos, fCode cCode)- ]+mapEntriesOrdered Contract{..} fParam fStorage fCode fView = snd <$> sortWith fst elements where- (paramPos, storagePos, codePos) = entriesOrderToInt cEntriesOrder+ getElemOrder ty = fromMaybe maxBound $ Map.lookup ty $ U.unEntriesOrder cEntriesOrder+ elements+ = first getElemOrder+ <$> [ (U.EntryParameter, fParam cParamNotes)+ , (U.EntryStorage, fStorage cStoreNotes)+ , (U.EntryCode, fCode cCode)]+ <> (toList cViews <&> \(SomeView v@View{..}) -> (U.EntryView vName, fView v))+{-# DEPRECATED mapEntriesOrdered "Unused and untested, essentially dead code; open an issue on the \+ \morley repository if you use this." #-}
src/Morley/Michelson/Typed/Convert.hs view
@@ -27,9 +27,10 @@ import Data.ByteArray qualified as ByteArray import Data.Constraint (Dict(..), (\\))+import Data.Default (def) import Data.List.NonEmpty ((<|)) import Data.Map qualified as Map-import Data.Singletons (Sing, demote, withSingI)+import Data.Singletons (Sing, demote) import Fmt (Buildable(..), fmt, listF, pretty) import Text.PrettyPrint.Leijen.Text (Doc) import Unsafe qualified (fromIntegral)@@ -55,9 +56,6 @@ unMutez) import Morley.Tezos.Crypto import Morley.Tezos.Crypto.BLS12381 qualified as BLS-import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519-import Morley.Tezos.Crypto.P256 qualified as P256-import Morley.Tezos.Crypto.Secp256k1 qualified as Secp256k1 import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes) import Morley.Util.PeanoNatural (fromPeanoNatural, singPeanoVal) import Morley.Util.Sing (eqParamSing)@@ -77,7 +75,7 @@ , contractStorage = untypeDemoteT @store , contractCode = instrToOps $ unContractCode contract , entriesOrder = U.canonicalEntriesOrder- , contractViews = []+ , contractViews = def } convertView :: forall arg store ret. View arg store ret -> U.View@@ -94,12 +92,12 @@ -- | Convert typed t'Contract' to an untyped t'U.Contract'. convertContract :: Contract param store -> U.Contract-convertContract fc@Contract{} =- let c = convertContractCode (cCode fc)- in c { U.contractParameter = convertParamNotes (cParamNotes fc)- , U.contractStorage = mkUType (cStoreNotes fc)- , U.entriesOrder = cEntriesOrder fc- , U.contractViews = convertSomeView <$> toList (cViews fc)+convertContract Contract{..} =+ let c = convertContractCode cCode+ in c { U.contractParameter = convertParamNotes cParamNotes+ , U.contractStorage = mkUType cStoreNotes+ , U.entriesOrder = cEntriesOrder+ , U.contractViews = U.UnsafeViewsSet $ convertSomeView <$> unViewsSet cViews } -- Note: if you change this type, check 'untypeValueImpl' wildcard patterns.@@ -174,10 +172,6 @@ case opts of Readable -> U.ValueString $ mformatEpAddress a _ -> U.ValueBytes . U.InternalByteString $ encodeEpAddress a- (VTxRollupL2Address (TxRollupL2Address a), _) ->- case opts of- Readable -> U.ValueString $ mformatHash a- _ -> U.ValueBytes . U.InternalByteString $ hashToBytes a (VKey b, _) -> case opts of Readable -> U.ValueString $ mformatPublicKey b@@ -264,31 +258,23 @@ hashToBytes :: Hash kind -> ByteString hashToBytes Hash{..} = (<> hBytes) $ case hTag of- HashKey KeyTypeEd25519 -> "\x00"- HashKey KeyTypeSecp256k1 -> "\x01"- HashKey KeyTypeP256 -> "\x02"+ HashKey kt -> one $ keyTypeTag kt HashContract -> ""- HashBLS -> ""- HashTXR -> ""+ HashSR -> "" keyToBytes :: PublicKey -> ByteString- keyToBytes = \case- PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk- PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk- PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk+ keyToBytes x = one (keyTypeTag $ publicKeyType x) <> publicKeyToBytes x encodeEpAddress :: EpAddress -> ByteString encodeEpAddress (EpAddress addr epName) = encodeAddress addr <> encodeEpName epName - encodeAddress :: KindedAddress kind -> ByteString- encodeAddress = \case- ImplicitAddress keyHash ->- "\x00" <> hashToBytes keyHash- ContractAddress hash ->- "\x01" <> hashToBytes hash <> "\x00"- TxRollupAddress hash ->- "\x02" <> hashToBytes hash <> "\x00"+ encodeAddress :: forall kind. KindedAddress kind -> ByteString+ encodeAddress addr = one (addressKindTag ak) <> case addr of+ ImplicitAddress keyHash -> hashToBytes keyHash+ ContractAddress hash -> hashToBytes hash <> "\x00"+ SmartRollupAddress hash -> hashToBytes hash <> "\x00"+ where ak = demote @kind \\ addressKindSanity addr encodeEpName :: EpName -> ByteString encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize@@ -322,7 +308,6 @@ Nested sq -> one $ U.SeqEx $ instrToOps sq DocGroup _ sq -> instrToOpsImpl opts sq Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext- FrameInstr _ i -> instrToOpsImpl opts i -- TODO [#283]: After representation of locations is polished, -- this place should be updated to pass it from typed to untyped ASTs. WithLoc _ i -> instrToOpsImpl opts i@@ -416,6 +401,8 @@ AnnLE ann -> annotateInstr ann U.LE AnnGE ann -> annotateInstr ann U.GE AnnINT ann -> annotateInstr ann U.INT+ AnnNAT ann -> annotateInstr ann U.NAT+ AnnBYTES ann -> annotateInstr ann U.BYTES AnnVIEW ann viewName -> annotateInstr ann (flip U.VIEW viewName) AnnSELF ann sepc -> annotateInstr ann U.SELF (epNameToRefAnn $ sepcName sepc)@@ -531,7 +518,7 @@ -- Since not for all types it is possible to produce a sensible example, -- the result is optional. E.g. for operations, @never@, not proper -- types like @contract operation@ we return 'Nothing'.-sampleTypedValue :: forall t. Sing t -> Maybe (Value t)+sampleTypedValue :: forall t. WellTyped t => Sing t -> Maybe (Value t) sampleTypedValue = \case STInt -> Just $ VInt -1 STNat -> Just $ VNat 0@@ -555,55 +542,30 @@ -- primes involved. STChest -> Nothing STChestKey -> Nothing- STTxRollupL2Address -> Just $ VTxRollupL2Address $ TxRollupL2Address $- unsafe $ parseHash "tz4LVHYD4P4T5NHCuwJbxQvwVURF62seE3Qa" STNever -> Nothing STSaplingState _ -> Nothing STSaplingTransaction _ -> Nothing- STOption t ->- withSingI t $ VOption . Just <$> sampleTypedValue t- STList t ->- withSingI t $ VList . one <$> sampleTypedValue t- STSet t -> withSingI t $ do- Dict <- comparabilityPresence t- VSet . one <$> sampleTypedValue t- STContract t -> withSingI t $ do- Dict <- rightToMaybe $ getWTP @t- Dict <- opAbsense t- Dict <- nestedBigMapsAbsense t- pure . VContract (eaAddress sampleAddress) $ SomeEpc unsafeEpcCallRoot- STTicket t -> withSingI t $ do- cmpProof <- comparabilityPresence t+ STOption t -> VOption . Just <$> sampleTypedValue t+ STList t -> VList . one <$> sampleTypedValue t+ STSet t -> VSet . one <$> sampleTypedValue t+ STContract _ -> pure . VContract (eaAddress sampleAddress) $ SomeEpc unsafeEpcCallRoot+ STTicket t -> do dat <- sampleTypedValue t VNat amount <- sampleTypedValue STNat- case cmpProof of- Dict -> return $ VTicket (MkAddress sampleCTAddress) dat amount- STPair t1 t2 -> withSingI t1 $ withSingI t2 $ do- val1 <- sampleTypedValue t1- val2 <- sampleTypedValue t2- pure $ VPair (val1, val2)- STOr tl tr -> withSingI tl $ withSingI tr $ asum- [ VOr . Left <$> sampleTypedValue tl- , VOr . Right <$> sampleTypedValue tr- ]- STMap t1 t2 -> withSingI t1 $ withSingI t2 $ do- val1 <- sampleTypedValue t1- val2 <- sampleTypedValue t2- case checkComparability t1 of- CanBeCompared -> pure $ VMap $ Map.fromList [(val1, val2)]- CannotBeCompared -> Nothing- STBigMap t1 t2 -> withSingI t1 $ withSingI t2 $ do- val1 <- sampleTypedValue t1- val2 <- sampleTypedValue t2- case (checkComparability t1, bigMapAbsense t2) of- (CanBeCompared, Just Dict) -> pure $ VBigMap Nothing $ Map.fromList [(val1, val2)]- _ -> Nothing- STLambda v (t2 :: Sing t2) -> withSingI v $ withSingI t2 $- case checkScope @(ConstantScope t2) of- Right Dict -> do- val <- sampleTypedValue t2- pure $ mkVLam $ RfNormal (DROP `Seq` PUSH val)- _ -> pure $ mkVLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)+ pure $ VTicket (MkAddress sampleCTAddress) dat amount+ STPair t1 t2 -> VPair ... (,) <$> sampleTypedValue t1 <*> sampleTypedValue t2+ STOr tl tr ->+ VOr . Left <$> sampleTypedValue tl+ <|> VOr . Right <$> sampleTypedValue tr+ STMap t1 t2 ->+ (\k v -> VMap $ Map.fromList [(k, v)]) <$> sampleTypedValue t1 <*> sampleTypedValue t2+ STBigMap t1 t2 -> (\k v -> VBigMap Nothing $ Map.fromList [(k, v)]) <$>+ sampleTypedValue t1 <*> sampleTypedValue t2+ STLambda _ (t2 :: Sing t2) -> case checkScope @(ConstantScope t2) of+ Right Dict -> do+ val <- sampleTypedValue t2+ pure $ mkVLam $ RfNormal (DROP `Seq` PUSH val)+ _ -> pure $ mkVLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH) where sampleCTAddress = [ta|KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB|] sampleAddress = unsafe . parseEpAddress $ formatAddress sampleCTAddress
src/Morley/Michelson/Typed/Extract.hs view
@@ -93,9 +93,6 @@ Un.TNever -> cont (NTNever tn) - Un.TTxRollupL2Address ->- cont (NTTxRollupL2Address tn)- Un.TSaplingState n -> (\(SomeSing s) -> withSingI s $ cont (NTSaplingState tn s)
src/Morley/Michelson/Typed/Haskell/Doc.hs view
@@ -13,6 +13,9 @@ , frNameL, frDescriptionL, frTypeRepL , WithinParens (..) , TypeHasDoc (..)+ , TypeHasFieldNamingStrategy (..)+ , FieldCamelCase+ , FieldSnakeCase , TypeDocHaskellRep , TypeDocMichelsonRep , FieldDescriptions@@ -34,6 +37,8 @@ , haskellAddNewtypeField , haskellRepNoFields , haskellRepStripFieldPrefix+ , haskellRepMap+ , haskellRepAdjust , homomorphicTypeDocMichelsonRep , concreteTypeDocMichelsonRep , unsafeConcreteTypeDocMichelsonRep@@ -51,10 +56,8 @@ ) where import Control.Lens (_Just, each, to)-import Data.Char (isLower, isUpper, toLower) import Data.List (lookup) import Data.Singletons (SingI, demote)-import Data.Text qualified as T import Data.Typeable (typeRep, typeRepArgs) import Fmt (Buildable, Builder, build, (+|), (|+)) import GHC.Generics ((:*:)(..), (:+:)(..))@@ -76,6 +79,7 @@ import Morley.Util.Lens import Morley.Util.Markdown import Morley.Util.Named+import Morley.Util.Text import Morley.Util.Typeable -- | Stands for representation of some Haskell ADT corresponding to@@ -166,6 +170,43 @@ wrap = if null (typeRepArgs rep) then id else applyWithinParens wp in wrap $ build @Text $ show rep +-- | Field naming strategy used by a type. 'id' by default.+--+-- Some common options include:+-- > typeFieldNamingStrategy = stripFieldPrefix+-- > typeFieldNamingStrategy = toSnake . dropPrefix+--+-- This is used by the default implementation of 'typeDocHaskellRep' and+-- intended to be reused downstream.+--+-- You can also use @DerivingVia@ together with 'FieldCamelCase' and+-- 'FieldSnakeCase' to easily define instances of this class:+--+-- > data MyType = ... deriving TypeHasFieldNamingStrategy via FieldCamelCase+class TypeHasFieldNamingStrategy a where+ typeFieldNamingStrategy :: Text -> Text+ typeFieldNamingStrategy = id++instance {-# OVERLAPPABLE #-} TypeHasFieldNamingStrategy a++-- | Empty datatype used as marker for @DerivingVia@ with+-- 'TypeHasFieldNamingStrategy'.+--+-- Uses 'stripFieldPrefix' strategy.+data FieldCamelCase++instance TypeHasFieldNamingStrategy FieldCamelCase where+ typeFieldNamingStrategy = stripFieldPrefix++-- | Empty datatype used as marker for @DerivingVia@ with+-- 'TypeHasFieldNamingStrategy'.+--+-- Uses @'toSnake' . 'dropPrefix'@ strategy.+data FieldSnakeCase++instance TypeHasFieldNamingStrategy FieldSnakeCase where+ typeFieldNamingStrategy = toSnake . dropPrefix+ -- | Description for a Haskell type appearing in documentation. class ( Typeable a , SingI (TypeDocFieldDescriptions a)@@ -226,18 +267,21 @@ -- -- For homomorphic types use 'homomorphicTypeDocHaskellRep' implementation. --- -- For polymorhpic types consider using 'concreteTypeDocHaskellRep' as implementation.+ -- For polymorphic types consider using 'concreteTypeDocHaskellRep' as implementation. -- -- Modifier 'haskellRepNoFields' can be used to hide names of fields, -- beneficial for newtypes. --- -- Another modifier called 'haskellRepStripFieldPrefix' can be used for datatypes- -- to leave only meaningful part of name in every field.+ -- Use 'haskellRepAdjust' or 'haskellRepMap' for more involved adjustments.+ --+ -- Also, consider defining an instance of 'TypeHasFieldNamingStrategy' instead+ -- of defining this method -- the former can be used downstream, e.g. in+ -- lorentz, for better naming consistency. typeDocHaskellRep :: TypeDocHaskellRep a default typeDocHaskellRep- :: (Generic a, GTypeHasDoc (G.Rep a), IsHomomorphic a)+ :: (Generic a, GTypeHasDoc (G.Rep a), IsHomomorphic a, TypeHasFieldNamingStrategy a) => TypeDocHaskellRep a- typeDocHaskellRep = haskellRepStripFieldPrefix homomorphicTypeDocHaskellRep+ typeDocHaskellRep = haskellRepMap (typeFieldNamingStrategy @a) homomorphicTypeDocHaskellRep -- | Description of constructors and fields of @a@. --@@ -257,7 +301,7 @@ -- -- For homomorphic types use 'homomorphicTypeDocMichelsonRep' implementation. --- -- For polymorhpic types consider using 'concreteTypeDocMichelsonRep' as implementation.+ -- For polymorphic types consider using 'concreteTypeDocMichelsonRep' as implementation. typeDocMichelsonRep :: TypeDocMichelsonRep a default typeDocMichelsonRep :: (KnownIsoT a, IsHomomorphic a)@@ -278,7 +322,7 @@ -- For example, for some @newtype MyNewtype = MyNewtype (Integer, Natural)@ -- we would not specify the first element in the pair because @MyNewtype@ is -- already a concrete type, and second element would contain @(Integer, Natural)@.--- For polymorhpic types like @newtype MyPolyNewtype a = MyPolyNewtype (Text, a)@,+-- For polymorphic types like @newtype MyPolyNewtype a = MyPolyNewtype (Text, a)@, -- we want to describe its representation on some example of @a@, because -- working with type variables is too non-trivial; so the first element of -- the pair may be e.g. @"MyPolyNewType Integer"@, and the second one shows@@ -287,7 +331,7 @@ -- When rendered, values of this type look like: -- -- * @(Integer, Natural)@ - for homomorphic type.--- * @MyError Integer = (Text, Integer)@ - concrete sample for polymorhpic type.+-- * @MyError Integer = (Text, Integer)@ - concrete sample for polymorphic type. type TypeDocHaskellRep a = Proxy a -> FieldDescriptionsV -> Maybe (Maybe DocTypeRepLHS, ADTRep SomeTypeWithDoc) @@ -300,7 +344,7 @@ -- Examples of rendered representation: -- -- * @pair int nat@ - for homomorphic type.--- * @MyError Integer = pair string int@ - concrete sample for polymorhpic type.+-- * @MyError Integer = pair string int@ - concrete sample for polymorphic type. type TypeDocMichelsonRep a = Proxy a -> (Maybe DocTypeRepLHS, T) @@ -310,7 +354,7 @@ -- | When rendering type's inner representation, this stands for name of ----- Having this makes sense for polymorhpic types, when you want to render+-- Having this makes sense for polymorphic types, when you want to render -- representation of some concrete instantiation of that type. newtype DocTypeRepLHS = DocTypeRepLHS Text deriving newtype (IsString, Buildable)@@ -512,10 +556,10 @@ -- | Implement 'typeDocHaskellRep' for a homomorphic type. -- -- Note that it does not require your type to be of 'IsHomomorphic' instance,--- which can be useful for some polymorhpic types which, for documentation+-- which can be useful for some polymorphic types which, for documentation -- purposes, we want to consider homomorphic. ----- Example: 'Operation' is in fact polymorhpic, but we don't want this fact to+-- Example: 'Operation' is in fact polymorphic, but we don't want this fact to -- be reflected in the documentation. homomorphicTypeDocHaskellRep :: forall a.@@ -528,7 +572,7 @@ -- | Implement 'typeDocHaskellRep' on example of given concrete type. ----- This is a best effort attempt to implement 'typeDocHaskellRep' for polymorhpic+-- This is a best effort attempt to implement 'typeDocHaskellRep' for polymorphic -- types, as soon as there is no simple way to preserve type variables when -- automatically deriving Haskell representation of a type. concreteTypeDocHaskellRep@@ -558,38 +602,34 @@ -- -- Use this when rendering fields names is undesired. haskellRepNoFields :: TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellRepNoFields mkRep =- \p descr -> second (mapADTRepFields (const Nothing)) <$> mkRep p descr+haskellRepNoFields = haskellRepAdjust (const Nothing) +-- | Like 'haskellRepAdjust', but can't add or remove field names.+haskellRepMap :: (Text -> Text) -> TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellRepMap = haskellRepAdjust . fmap++-- | Map over fields with 'stripFieldPrefix'. Equivalent to @haskellRepMap+-- stripFieldPrefix@. Left for compatibility.+haskellRepStripFieldPrefix :: TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellRepStripFieldPrefix = haskellRepMap stripFieldPrefix+{-# DEPRECATED haskellRepStripFieldPrefix+ "Use 'haskellRepMap' with utilities from \"Morley.Util.Text\" instead" #-}+ -- | Add field name for @newtype@. -- -- Since @newtype@ field is automatically erased. Use this function -- to add the desired field name. haskellAddNewtypeField :: Text -> TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellAddNewtypeField fieldName mkRep =- \p descr -> second (mapADTRepFields (const (Just fieldName))) <$> mkRep p descr+haskellAddNewtypeField fieldName = haskellRepAdjust $ const $ Just fieldName --- | Cut fields prefixes which we use according to the style guide.------ E.g. @cmMyField@ field will be transformed to @myField@.-haskellRepStripFieldPrefix- :: HasCallStack- => TypeDocHaskellRep a -> TypeDocHaskellRep a-haskellRepStripFieldPrefix mkRep =- \p descr -> second (mapADTRepFields (fmap stripPrefix)) <$> mkRep p descr- where- stripPrefix fieldName =- case T.uncons $ T.dropWhile isLower fieldName of- Nothing -> error $ "Field '" <> fieldName <> "' has no prefix"- Just (c, cs) ->- -- For fields like @ciUSPosition@ we should not lead the first letter- -- to lower case like @uSPosition@.- let isAbbreviation = case T.uncons cs of- Just (c2, _)- | isUpper c2 -> True- | otherwise -> False- Nothing -> False- in T.cons (if isAbbreviation then c else toLower c) cs+-- | Adjust field names using a function. Can add or remove field names.+haskellRepAdjust :: (Maybe Text -> Maybe Text) -> TypeDocHaskellRep a -> TypeDocHaskellRep a+haskellRepAdjust = fmap . fmap . fmap . fmap . mapADTRepFields+-- This is ridiculous, but we really do need to map over a functor 4 levels+-- deep. This will be less confusing if you look at 'TypeDocHaskellRep'+-- definition above. In a previous iteration of this function, we had a lambda,+-- 'second', 'fmap' and '<$>' all mixed together, and it was even less clear+-- what's going on. -- @lierdakil -- | Implement 'typeDocMichelsonRep' for homomorphic type. homomorphicTypeDocMichelsonRep@@ -798,6 +838,7 @@ typeDocName _ = "()" typeDocMdDescription = "Unit primitive." typeDocDependencies _ = []+ typeDocHaskellRep _ _ = Nothing instance TypeHasDoc Chest where typeDocName _ = "Chest"
src/Morley/Michelson/Typed/Haskell/Instr/Product.hs view
@@ -213,7 +213,7 @@ case checkScope @(DupableScope $ GValueType x) of Left{} -> Nothing Right Dict -> Just $- DUP `Seq` gInstrToField @name @x @path @fieldTy `Seq` FrameInstr Proxy cont+ DUP `Seq` gInstrToField @name @x @path @fieldTy `Seq` frameInstr cont instance GInstrGet name x path f => GInstrGet name (G.M1 t i x) path f where gInstrToField = gInstrToField @name @x @path @f@@ -222,7 +222,7 @@ instance (IsoValue f, ToT f ~ ToT f') => GInstrGet name (G.Rec0 f) '[] f' where gInstrToField = Nop- gInstrGetFieldOpen contWDup _ = FrameInstr Proxy contWDup+ gInstrGetFieldOpen contWDup _ = frameInstr contWDup instance (GInstrGet name x path f, GIsoValue y) => GInstrGet name (x :*: y) ('L ': path) f where gInstrToField = CAR `Seq` gInstrToField @name @x @path @f@@ -317,7 +317,7 @@ instance (IsoValue f, ToT f ~ ToT f') => GInstrSetField name (G.Rec0 f) '[] f' where- gInstrSetFieldOpen cont = FrameInstr Proxy cont+ gInstrSetFieldOpen cont = frameInstr cont instance (GInstrSetField name x path f, GIsoValue y) => GInstrSetField name (x :*: y) ('L ': path) f where gInstrSetFieldOpen cont =
src/Morley/Michelson/Typed/Haskell/Value.hs view
@@ -243,11 +243,6 @@ toVal = VChestKey fromVal (VChestKey x) = x -instance IsoValue TxRollupL2Address where- type ToT TxRollupL2Address = 'TTxRollupL2Address- toVal = VTxRollupL2Address- fromVal (VTxRollupL2Address x) = x- deriving newtype instance IsoValue a => IsoValue (Identity a) deriving newtype instance IsoValue a => IsoValue (NamedF Identity a name) deriving newtype instance IsoValue a => IsoValue (NamedF Maybe a name)
src/Morley/Michelson/Typed/Instr.hs view
@@ -1,8 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA -{-# OPTIONS_GHC -Wno-orphans #-}- -- | Module, containing data types for Michelson value. module Morley.Michelson.Typed.Instr ( Instr (..@@ -101,6 +99,8 @@ , SAPLING_VERIFY_UPDATE , MIN_BLOCK_TIME , EMIT+ , BYTES+ , NAT ) , castInstr , pattern (:#)@@ -112,34 +112,19 @@ , TestAssert (..) , SomeMeta (..) , pattern ConcreteMeta- , ConstraintDUPN- , ConstraintDUPN'- , ConstraintDIPN- , ConstraintDIPN'- , ConstraintDIG- , ConstraintDIG'- , ConstraintDUG- , ConstraintDUG'- , ConstraintPairN- , PairN- , RightComb- , ConstraintUnpairN- , UnpairN- , ConstraintGetN- , GetN- , ConstraintUpdateN- , UpdateN+ , frameInstr ) where import Prelude hiding (EQ, GT, LT) +import Data.Constraint ((\\)) import Data.Default (def) import Data.List (stripPrefix) import Data.Singletons (Sing) import Data.Type.Equality ((:~:)(..)) import Data.Typeable (cast) import Fmt (Buildable(..), (+|), (|+))-import GHC.TypeNats (Nat, type (+))+import GHC.TypeNats (Nat) import Language.Haskell.TH import Text.Show qualified as T @@ -149,12 +134,11 @@ import Morley.Michelson.Typed.Arith import Morley.Michelson.Typed.Contract import Morley.Michelson.Typed.Entrypoints+import Morley.Michelson.Typed.Instr.Constraints+import Morley.Michelson.Typed.Instr.Internal.Proofs import Morley.Michelson.Typed.Polymorphic import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T (T(..))-import Morley.Michelson.Typed.TypeLevel- (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,- CombedPairNodeIndexIsValid, IsPair) import Morley.Michelson.Typed.Value (RemFail(..), Value'(..)) import Morley.Michelson.Typed.View import Morley.Michelson.Untyped (AnyAnn, FieldAnn, StackTypePattern, TypeAnn, VarAnn)@@ -162,8 +146,7 @@ import Morley.Util.PeanoNatural import Morley.Util.Sing (eqI) import Morley.Util.TH-import Morley.Util.Type (FailUnless, If, KnownList, type (++))-import Morley.Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)))+import Morley.Util.Type (type (++)) {-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-} @@ -174,142 +157,7 @@ -- >>> import qualified Debug (show) -- >>> :set -XPartialTypeSignatures --- | Constraint that is used in DUPN, we want to share it with--- typechecking code and eDSL code.-type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =- ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True- , inp ~ (LazyTake (Decrement n) inp ++ (a ': Drop n inp))- , out ~ (a ': inp)- )--type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a---- | Constraint that is used in DIPN, we want to share it with--- typechecking code and eDSL code.-type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])- (out :: [kind]) (s :: [kind]) (s' :: [kind]) =- ( RequireLongerOrSameLength inp n- , LazyTake n inp ++ s ~ inp- , LazyTake n inp ++ s' ~ out- , s ~ Drop n inp- , s' ~ Drop n out- )--type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'---- | Constraint that is used in DIG, we want to share it with--- typechecking code and eDSL code.-type ConstraintDIG' kind (n :: Peano) (inp :: [kind])- (out :: [kind]) (a :: kind) =- ( RequireLongerThan inp n- , out ~ a ': LazyTake n inp ++ Drop ('S n) inp- , inp ~ LazyTake n (Drop ('S 'Z) out) ++ (a ': Drop ('S n) out)- )--type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a---- | Constraint that is used in DUG, we want to share it with--- typechecking code and eDSL code.-type ConstraintDUG' kind (n :: Peano) (inp :: [kind])- (out :: [kind]) (a :: kind) =- ConstraintDIG' kind n out inp a--type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a--type ConstraintPairN (n :: Peano) (inp :: [T]) =- ( RequireLongerOrSameLength inp n- , FailUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")- )--type PairN (n :: Peano) (s :: [T]) = RightComb (LazyTake n s) ': Drop n s---- | Folds a stack into a right-combed pair.------ > RightComb '[ 'TInt, 'TString, 'TUnit ]--- > ~--- > 'TPair 'TInt ('TPair 'TString 'TUnit)-type family RightComb (s :: [T]) :: T where- RightComb '[ x, y ] = 'TPair x y- RightComb (x ': xs) = 'TPair x (RightComb xs)--type ConstraintUnpairN (n :: Peano) (pair :: T) =- ( FailUnless (n >= ToPeano 2)- ('Text "'UNPAIR n' expects n ≥ 2")-- , FailUnless (CombedPairLeafCountIsAtLeast n pair)- (If (IsPair pair)- ('Text "'UNPAIR "- ':<>: 'ShowType (FromPeano n)- ':<>: 'Text "' expects a right-combed pair with at least "- ':<>: 'ShowType (FromPeano n)- ':<>: 'Text " elements at the top of the stack,"- ':$$: 'Text "but the pair only contains "- ':<>: 'ShowType (FromPeano (CombedPairLeafCount pair))- ':<>: 'Text " elements.")- ('Text "Expected a pair at the top of the stack, but found: "- ':<>: 'ShowType pair- )- )- )---- | Splits a right-combed pair into @n@ elements.------ > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString 'TUnit))--- > ~--- > '[ 'TInt, 'TString, 'TUnit]------ > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString ('TPair 'TUnit 'TInt)))--- > ~--- > '[ 'TInt, 'TString, 'TPair 'TUnit 'TInt]-type family UnpairN (n :: Peano) (s :: T) :: [T] where- UnpairN ('S ('S 'Z)) ('TPair x y) = [x, y]- UnpairN ('S n) ('TPair x y) = x : UnpairN n y--type ConstraintGetN (ix :: Peano) (pair :: T) =- ( FailUnless (CombedPairNodeIndexIsValid ix pair)- (If (IsPair pair)- ('Text "'GET "- ':<>: 'ShowType (FromPeano ix)- ':<>: 'Text "' expects a right-combed pair with at least "- ':<>: 'ShowType (FromPeano ix + 1)- ':<>: 'Text " nodes at the top of the stack,"- ':$$: 'Text "but the pair only contains "- ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))- ':<>: 'Text " nodes.")- ('Text "Expected a pair at the top of the stack, but found: "- ':<>: 'ShowType pair- )- )- )---- | Get the node at index @ix@ of a right-combed pair.-type family GetN (ix :: Peano) (pair :: T) :: T where- GetN 'Z val = val- GetN ('S 'Z) ('TPair left _) = left- GetN ('S ('S n)) ('TPair _ right) = GetN n right--type ConstraintUpdateN (ix :: Peano) (pair :: T) =- ( FailUnless (CombedPairNodeIndexIsValid ix pair)- (If (IsPair pair)- ('Text "'UPDATE "- ':<>: 'ShowType (FromPeano ix)- ':<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least "- ':<>: 'ShowType (FromPeano ix + 1)- ':<>: 'Text " nodes,"- ':$$: 'Text "but the pair only contains "- ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))- ':<>: 'Text " nodes.")- ('Text "Expected the 2nd element of the stack to be a pair, but found: "- ':<>: 'ShowType pair- )- )- )---- | Update the node at index @ix@ of a right-combed pair.-type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T where- UpdateN 'Z val _ = val- UpdateN ('S 'Z) val ('TPair _ right) = 'TPair val right- UpdateN ('S ('S n)) val ('TPair left right) = 'TPair left (UpdateN n val right)+infixr 8 `Seq` -- | Representation of Michelson instruction or sequence -- of instructions.@@ -360,29 +208,6 @@ -- | A wrapper allowing arbitrary user metadata to be stored by some instruction. -- TODO [#689]: Use this instead of `DOC_ITEM`. Meta :: SomeMeta -> Instr a b -> Instr a b-- -- | Execute given instruction on truncated stack.- --- -- This can wrap only instructions with at least one non-failing execution- -- branch.- --- -- Morley has no such instruction, it is used solely in eDSLs.- -- This instruction is sound because for all Michelson instructions- -- the following property holds: if some code accepts stack @i@ and- -- produces stack @o@, when it can also be run on stack @i + s@- -- producing stack @o + s@; and also because Michelson never makes- -- implicit assumptions on types, rather you have to express all- -- "yet ambiguous" type information in code.- -- We could make this not an instruction but rather a function- -- which modifies an instruction (this would also automatically prove- -- soundness of used transformation), but it occurred to be tricky- -- (in particular for TestAssert and DipN and family), so let's leave- -- this for future work.- FrameInstr- :: forall a b s.- KnownList a- => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)- Seq :: Instr a b -> Instr b c -> Instr a c -- | Nop operation. Missing in Michelson spec, added to parse construction -- like `IF {} { SWAP; DROP; }`.@@ -686,7 +511,7 @@ => AnnVar -> Instr (n ': m ': s) (ArithRes Xor n m ': s) AnnNOT- :: UnaryArithOp Not n+ :: (SingI n, UnaryArithOp Not n) => AnnVar -> Instr (n ': s) (UnaryArithRes Not n ': s) AnnCOMPARE@@ -721,6 +546,13 @@ :: ToIntArithOp n => AnnVar -> Instr (n ': s) ('TInt ': s)+ AnnBYTES+ :: ToBytesArithOp n+ => AnnVar+ -> Instr (n ': s) ('TBytes ': s)+ AnnNAT+ :: AnnVar+ -> Instr ('TBytes ': s) ('TNat ': s) AnnVIEW -- Here really only the return type is constrained -- because it is given explicitly@@ -968,6 +800,154 @@ -> Instr s r pattern LAMBDA_REC code <- AnnLAMBDA_REC _ code where LAMBDA_REC code = AnnLAMBDA_REC def $ giveNotInView code++-- | Execute given instruction on truncated stack.+--+-- This is sound because for all Michelson instructions the following property+-- holds: if some code accepts stack @i@ and produces stack @o@, when it can+-- also be run on stack @i + s@ producing stack @o + s@; and also because+-- Michelson never makes implicit assumptions on types, rather you have to+-- express all "yet ambiguous" type information in code.+--+-- The complexity of this operation is linear in the number of instructions. If+-- possible, avoid nested uses as that would imply multiple traversals. Worst+-- case, complexity can become quadratic.+frameInstr :: forall s a b. Instr a b -> Instr (a ++ s) (b ++ s)+frameInstr = \case+ Seq i1 i2 -> Seq (go i1) (go i2)+ WithLoc loc instr -> WithLoc loc $ go instr+ Meta m instr -> Meta m $ go instr+ Nested i1 -> Nested $ go i1+ DocGroup dg i1 -> DocGroup dg $ go i1+ IF_NONE i1 i2 -> IF_NONE (go i1) (go i2)+ IF_LEFT i1 i2 -> IF_LEFT (go i1) (go i2)+ IF_CONS i1 i2 -> IF_CONS (go i1) (go i2)+ IF i1 i2 -> IF (go i1) (go i2)+ AnnMAP ann i1 -> AnnMAP ann $ go i1+ ITER i1 -> ITER $ go i1+ LOOP i1 -> LOOP $ go i1+ LOOP_LEFT i1 -> LOOP_LEFT $ go i1+ DIP i1 -> DIP $ go i1+ DIPN n (i1 :: Instr s1 s1') -> DIPN n (go i1) \\ dipNExtensionThm @s @a @b @s1 @s1' n+ AnnPUSH ann v -> AnnPUSH ann v+ AnnLAMBDA ann lam -> AnnLAMBDA ann lam+ AnnLAMBDA_REC ann lam -> AnnLAMBDA_REC ann lam+ AnnCREATE_CONTRACT ann contract -> AnnCREATE_CONTRACT ann contract+ Nop -> Nop+ Ext (TEST_ASSERT (TestAssert t c i)) -> Ext $ TEST_ASSERT $ TestAssert t (comment c) (go i)+ Ext (PRINT x) -> Ext $ PRINT $ comment x+ Ext (DOC_ITEM x) -> Ext (DOC_ITEM x)+ Ext (COMMENT_ITEM x) -> Ext (COMMENT_ITEM x)+ Ext (STACKTYPE x) -> Ext (STACKTYPE x)+ AnnCAR anns -> AnnCAR anns+ AnnCDR anns -> AnnCDR anns+ DROP -> DROP+ DROPN n -> DROPN n \\ dropNExtensionThm @s @a n+ AnnDUP anns -> AnnDUP anns+ AnnDUPN anns n -> AnnDUPN anns n \\ dupNExtensionThm @s @a @b n+ SWAP -> SWAP+ DIG n -> DIG n \\ digNExtensionThm @s @a @b n+ DUG n -> DUG n \\ dugNExtensionThm @s @a @b n+ AnnSOME anns -> AnnSOME anns+ AnnNONE anns -> AnnNONE anns+ AnnUNIT anns -> AnnUNIT anns+ AnnPAIR anns -> AnnPAIR anns+ AnnUNPAIR anns -> AnnUNPAIR anns+ AnnPAIRN anns n -> AnnPAIRN anns n \\ pairNExtensionThm @s @a n+ UNPAIRN n -> UNPAIRN n \\ unpairNExtensionThm @s @a n+ AnnLEFT anns -> AnnLEFT anns+ AnnRIGHT anns -> AnnRIGHT anns+ AnnNIL anns -> AnnNIL anns+ AnnCONS anns -> AnnCONS anns+ AnnSIZE anns -> AnnSIZE anns+ AnnEMPTY_SET anns -> AnnEMPTY_SET anns+ AnnEMPTY_MAP anns -> AnnEMPTY_MAP anns+ AnnEMPTY_BIG_MAP anns -> AnnEMPTY_BIG_MAP anns+ AnnMEM anns -> AnnMEM anns+ AnnGET anns -> AnnGET anns+ AnnGETN anns n -> AnnGETN anns n+ AnnUPDATE anns -> AnnUPDATE anns+ AnnUPDATEN anns n -> AnnUPDATEN anns n+ AnnGET_AND_UPDATE anns -> AnnGET_AND_UPDATE anns+ AnnEXEC anns -> AnnEXEC anns+ AnnAPPLY anns -> AnnAPPLY anns+ FAILWITH -> FAILWITH+ AnnCAST anns -> AnnCAST anns+ AnnRENAME anns -> AnnRENAME anns+ AnnPACK anns -> AnnPACK anns+ AnnUNPACK anns -> AnnUNPACK anns+ AnnCONCAT anns -> AnnCONCAT anns+ AnnCONCAT' anns -> AnnCONCAT' anns+ AnnSLICE anns -> AnnSLICE anns+ AnnISNAT anns -> AnnISNAT anns+ AnnADD anns -> AnnADD anns+ AnnSUB anns -> AnnSUB anns+ AnnSUB_MUTEZ anns -> AnnSUB_MUTEZ anns+ AnnMUL anns -> AnnMUL anns+ AnnEDIV anns -> AnnEDIV anns+ AnnABS anns -> AnnABS anns+ AnnNEG anns -> AnnNEG anns+ AnnLSL anns -> AnnLSL anns+ AnnLSR anns -> AnnLSR anns+ AnnOR anns -> AnnOR anns+ AnnAND anns -> AnnAND anns+ AnnXOR anns -> AnnXOR anns+ AnnNOT anns -> AnnNOT anns+ AnnCOMPARE anns -> AnnCOMPARE anns+ AnnEQ anns -> AnnEQ anns+ AnnNEQ anns -> AnnNEQ anns+ AnnLT anns -> AnnLT anns+ AnnGT anns -> AnnGT anns+ AnnLE anns -> AnnLE anns+ AnnGE anns -> AnnGE anns+ AnnINT anns -> AnnINT anns+ AnnVIEW anns n -> AnnVIEW anns n+ AnnSELF anns ep -> AnnSELF anns ep+ AnnCONTRACT anns c -> AnnCONTRACT anns c+ AnnTRANSFER_TOKENS anns -> AnnTRANSFER_TOKENS anns+ AnnSET_DELEGATE anns -> AnnSET_DELEGATE anns+ AnnIMPLICIT_ACCOUNT anns -> AnnIMPLICIT_ACCOUNT anns+ AnnNOW anns -> AnnNOW anns+ AnnAMOUNT anns -> AnnAMOUNT anns+ AnnBALANCE anns -> AnnBALANCE anns+ AnnVOTING_POWER anns -> AnnVOTING_POWER anns+ AnnTOTAL_VOTING_POWER anns -> AnnTOTAL_VOTING_POWER anns+ AnnCHECK_SIGNATURE anns -> AnnCHECK_SIGNATURE anns+ AnnSHA256 anns -> AnnSHA256 anns+ AnnSHA512 anns -> AnnSHA512 anns+ AnnBLAKE2B anns -> AnnBLAKE2B anns+ AnnSHA3 anns -> AnnSHA3 anns+ AnnKECCAK anns -> AnnKECCAK anns+ AnnHASH_KEY anns -> AnnHASH_KEY anns+ AnnPAIRING_CHECK anns -> AnnPAIRING_CHECK anns+ AnnSOURCE anns -> AnnSOURCE anns+ AnnSENDER anns -> AnnSENDER anns+ AnnADDRESS anns -> AnnADDRESS anns+ AnnCHAIN_ID anns -> AnnCHAIN_ID anns+ AnnLEVEL anns -> AnnLEVEL anns+ AnnSELF_ADDRESS anns -> AnnSELF_ADDRESS anns+ NEVER -> NEVER+ AnnTICKET anns -> AnnTICKET anns+ AnnTICKET_DEPRECATED anns -> AnnTICKET_DEPRECATED anns+ AnnREAD_TICKET anns -> AnnREAD_TICKET anns+ AnnSPLIT_TICKET anns -> AnnSPLIT_TICKET anns+ AnnJOIN_TICKETS anns -> AnnJOIN_TICKETS anns+ AnnOPEN_CHEST anns -> AnnOPEN_CHEST anns+ AnnSAPLING_EMPTY_STATE anns n -> AnnSAPLING_EMPTY_STATE anns n+ AnnSAPLING_VERIFY_UPDATE anns -> AnnSAPLING_VERIFY_UPDATE anns+ AnnMIN_BLOCK_TIME anns -> AnnMIN_BLOCK_TIME anns+ AnnEMIT anns tag ty -> AnnEMIT anns tag ty+ AnnBYTES anns -> AnnBYTES anns+ AnnNAT anns -> AnnNAT anns+ where+ go :: forall a' b'. Instr a' b' -> Instr (a' ++ s) (b' ++ s)+ go = frameInstr @s++ comment :: PrintComment a -> PrintComment (a ++ s)+ comment (PrintComment c) = PrintComment $ c <&> \case+ Left t -> Left t+ Right (StackRef n) -> Right $ StackRef @(a ++ s) n+ \\ isLongerThanExtThm @a @s n deriveGADTNFData ''Instr
+ src/Morley/Michelson/Typed/Instr/Constraints.hs view
@@ -0,0 +1,175 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Constraints for some typed instructions we share accross a few places and+-- related type-level helpers.+module Morley.Michelson.Typed.Instr.Constraints+ ( ConstraintDUPN'+ , ConstraintDUPN+ , ConstraintDIPN'+ , ConstraintDIPN+ , ConstraintDIG'+ , ConstraintDIG+ , ConstraintDUG'+ , ConstraintDUG+ , ConstraintPairN+ , ConstraintUnpairN+ , ConstraintGetN+ , ConstraintUpdateN++ -- * Helpers+ , PairN+ , UnpairN+ , UpdateN+ , GetN+ , RightComb+ ) where++import Prelude hiding (EQ, GT, LT)++import GHC.TypeNats (type (+))++import Morley.Michelson.Typed.T (T(..))+import Morley.Michelson.Typed.TypeLevel+ (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,+ CombedPairNodeIndexIsValid, IsPair)+import Morley.Util.Peano+import Morley.Util.Type (FailUnless, If, type (++))+import Morley.Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)))++-- | Constraint that is used in DUPN, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =+ ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True+ , inp ~ (LazyTake (Decrement n) inp ++ (a ': Drop n inp))+ , out ~ (a ': inp)+ )++type ConstraintDUPN n inp out a = ConstraintDUPN' T n inp out a++-- | Constraint that is used in DIPN, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])+ (out :: [kind]) (s :: [kind]) (s' :: [kind]) =+ ( RequireLongerOrSameLength inp n+ , LazyTake n inp ++ s ~ inp+ , LazyTake n inp ++ s' ~ out+ , s ~ Drop n inp+ , s' ~ Drop n out+ )++type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'++-- | Constraint that is used in DIG, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDIG' kind (n :: Peano) (inp :: [kind])+ (out :: [kind]) (a :: kind) =+ ( RequireLongerThan inp n+ , out ~ a ': LazyTake n inp ++ Drop ('S n) inp+ , inp ~ LazyTake n (Drop ('S 'Z) out) ++ (a ': Drop ('S n) out)+ )++type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a++-- | Constraint that is used in DUG, we want to share it with+-- typechecking code and eDSL code.+type ConstraintDUG' kind (n :: Peano) (inp :: [kind])+ (out :: [kind]) (a :: kind) =+ ConstraintDIG' kind n out inp a++type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a++type ConstraintPairN (n :: Peano) (inp :: [T]) =+ ( RequireLongerOrSameLength inp n+ , FailUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")+ )++type PairN (n :: Peano) (s :: [T]) = RightComb (LazyTake n s) ': Drop n s++-- | Folds a stack into a right-combed pair.+--+-- > RightComb '[ 'TInt, 'TString, 'TUnit ]+-- > ~+-- > 'TPair 'TInt ('TPair 'TString 'TUnit)+type family RightComb (s :: [T]) :: T where+ RightComb '[ x, y ] = 'TPair x y+ RightComb (x ': xs) = 'TPair x (RightComb xs)++type ConstraintUnpairN (n :: Peano) (pair :: T) =+ ( FailUnless (n >= ToPeano 2)+ ('Text "'UNPAIR n' expects n ≥ 2")++ , FailUnless (CombedPairLeafCountIsAtLeast n pair)+ (If (IsPair pair)+ ('Text "'UNPAIR "+ ':<>: 'ShowType (FromPeano n)+ ':<>: 'Text "' expects a right-combed pair with at least "+ ':<>: 'ShowType (FromPeano n)+ ':<>: 'Text " elements at the top of the stack,"+ ':$$: 'Text "but the pair only contains "+ ':<>: 'ShowType (FromPeano (CombedPairLeafCount pair))+ ':<>: 'Text " elements.")+ ('Text "Expected a pair at the top of the stack, but found: "+ ':<>: 'ShowType pair+ )+ )+ )++-- | Splits a right-combed pair into @n@ elements.+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString 'TUnit))+-- > ~+-- > '[ 'TInt, 'TString, 'TUnit]+--+-- > UnpairN (ToPeano 3) ('TPair 'TInt ('TPair 'TString ('TPair 'TUnit 'TInt)))+-- > ~+-- > '[ 'TInt, 'TString, 'TPair 'TUnit 'TInt]+type family UnpairN (n :: Peano) (s :: T) :: [T] where+ UnpairN ('S ('S 'Z)) ('TPair x y) = [x, y]+ UnpairN ('S n) ('TPair x y) = x : UnpairN n y++type ConstraintGetN (ix :: Peano) (pair :: T) =+ ( FailUnless (CombedPairNodeIndexIsValid ix pair)+ (If (IsPair pair)+ ('Text "'GET "+ ':<>: 'ShowType (FromPeano ix)+ ':<>: 'Text "' expects a right-combed pair with at least "+ ':<>: 'ShowType (FromPeano ix + 1)+ ':<>: 'Text " nodes at the top of the stack,"+ ':$$: 'Text "but the pair only contains "+ ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+ ':<>: 'Text " nodes.")+ ('Text "Expected a pair at the top of the stack, but found: "+ ':<>: 'ShowType pair+ )+ )+ )++-- | Get the node at index @ix@ of a right-combed pair.+type family GetN (ix :: Peano) (pair :: T) :: T where+ GetN 'Z val = val+ GetN ('S 'Z) ('TPair left _) = left+ GetN ('S ('S n)) ('TPair _ right) = GetN n right++type ConstraintUpdateN (ix :: Peano) (pair :: T) =+ ( FailUnless (CombedPairNodeIndexIsValid ix pair)+ (If (IsPair pair)+ ('Text "'UPDATE "+ ':<>: 'ShowType (FromPeano ix)+ ':<>: 'Text "' expects the 2nd element of the stack to be a right-combed pair with at least "+ ':<>: 'ShowType (FromPeano ix + 1)+ ':<>: 'Text " nodes,"+ ':$$: 'Text "but the pair only contains "+ ':<>: 'ShowType (FromPeano (CombedPairNodeCount pair))+ ':<>: 'Text " nodes.")+ ('Text "Expected the 2nd element of the stack to be a pair, but found: "+ ':<>: 'ShowType pair+ )+ )+ )++-- | Update the node at index @ix@ of a right-combed pair.+type family UpdateN (ix :: Peano) (val :: T) (pair :: T) :: T where+ UpdateN 'Z val _ = val+ UpdateN ('S 'Z) val ('TPair _ right) = 'TPair val right+ UpdateN ('S ('S n)) val ('TPair left right) = 'TPair left (UpdateN n val right)
+ src/Morley/Michelson/Typed/Instr/Internal/Proofs.hs view
@@ -0,0 +1,194 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | Module, containing some internally used typelevel proofs.+module Morley.Michelson.Typed.Instr.Internal.Proofs+ ( module Morley.Michelson.Typed.Instr.Internal.Proofs+ ) where++import Prelude hiding (EQ, GT, LT)++import Data.Constraint (Dict(..), (\\))+import Data.Type.Equality ((:~:)(..))++import Morley.Michelson.Typed.Instr.Constraints+import Morley.Michelson.Typed.TypeLevel+import Morley.Util.Peano+import Morley.Util.PeanoNatural+import Morley.Util.StubbedProof+import Morley.Util.Type (KList(..), type (++))++assocThm :: forall a b c. (a ++ b) ++ c :~: a ++ (b ++ c)+assocThm = stubProof $ case assumeKnown @a of+ KNil -> Refl+ KCons _ (_ :: Proxy xs) -> Refl \\ assocThm @xs @b @c++takeExtensionThm+ :: forall a s n. IsLongerOrSameLength a n ~ 'True+ => PeanoNatural n+ -> LazyTake n (a ++ s) :~: LazyTake n a+takeExtensionThm n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ takeExtensionThm @xs @s m++dropExtensionThm+ :: forall a s n. IsLongerOrSameLength a n ~ 'True+ => PeanoNatural n+ -> Drop n (a ++ s) :~: Drop n a ++ s+dropExtensionThm n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ dropExtensionThm @xs @s m++isLongerOrSameLengthExtThm+ :: forall a s n. IsLongerOrSameLength a n ~ 'True+ => PeanoNatural n+ -> IsLongerOrSameLength (a ++ s) n :~: 'True+isLongerOrSameLengthExtThm n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ isLongerOrSameLengthExtThm @xs @s m++isLongerOrSameLengthDecThm+ :: forall a m. IsLongerOrSameLength a ('S m) ~ 'True+ => PeanoNatural ('S m)+ -> IsLongerOrSameLength a m :~: 'True+isLongerOrSameLengthDecThm n = stubProof $ case n of+ Succ Zero -> Refl+ Succ (Succ m) -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ isLongerOrSameLengthDecThm @xs (Succ m)++isLongerThanExtThm+ :: forall a s n. IsLongerThan a n ~ 'True+ => PeanoNatural n+ -> IsLongerThan (a ++ s) n :~: 'True+isLongerThanExtThm n = stubProof $ case n of+ Zero -> case assumeKnown @a of+ KCons{} -> Refl+ Succ m -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ isLongerThanExtThm @xs @s m++dropHeadThm+ :: forall x a n. IsLongerThan (x : a) n ~ 'True+ => PeanoNatural n+ -> IsLongerOrSameLength a n :~: 'True+dropHeadThm n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case assumeKnown @a of+ KCons (_ :: Proxy y) (_ :: Proxy xs) -> Refl \\ dropHeadThm @y @xs m++isLongerThanIncThm+ :: forall a n. IsLongerThan a n ~ 'True+ => PeanoNatural n+ -> IsLongerOrSameLength a ('S n) :~: 'True+isLongerThanIncThm n = stubProof $ case n of+ Zero -> case assumeKnown @a of+ KCons{} -> Refl+ Succ m -> case assumeKnown @a of+ KCons _ (_ :: Proxy xs) -> Refl \\ isLongerThanIncThm @xs m++dugLengthThm+ :: forall b x n. IsLongerThan b n ~ 'True+ => PeanoNatural n+ -> IsLongerThan (x ': LazyTake n b ++ Drop ('S n) b) n :~: 'True+dugLengthThm n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case assumeKnown @b of+ KCons (_ :: Proxy y) (_ :: Proxy xs) -> Refl \\ dugLengthThm @xs @y m++dropNExtensionThm+ :: forall s a b n. (Drop n a ~ b, IsLongerOrSameLength a n ~ 'True)+ => PeanoNatural n+ -> Dict (Drop n (a ++ s) ~ b ++ s, IsLongerOrSameLength (a ++ s) n ~ 'True)+dropNExtensionThm n = Dict+ \\ dropExtensionThm @a @s n+ \\ isLongerOrSameLengthExtThm @a @s n++dupNExtensionThm+ :: forall s a b n x. (b ~ x : a, ConstraintDUPN n a b x)+ => PeanoNatural n+ -> Dict (ConstraintDUPN n (a ++ s) (b ++ s) x)+dupNExtensionThm n@(Succ m) = Dict+ \\ isLongerOrSameLengthExtThm @a @s n+ \\ assocThm @(LazyTake (Decrement n) a) @(x : Drop n a) @s+ \\ takeExtensionThm @a @s m \\ isLongerOrSameLengthDecThm @a n+ \\ dropExtensionThm @a @s n++dugNExtensionThm+ :: forall s a b x r n. (a ~ x : r, ConstraintDUG n a b x)+ => PeanoNatural n+ -> Dict (ConstraintDUG n (a ++ s) (b ++ s) x)+dugNExtensionThm n = Dict+ \\ isLongerThanExtThm @b @s n+ \\ assocThm @(LazyTake n b) @(Drop ('S n) b) @s+ \\ takeExtensionThm @b @s n \\ isLongerOrSameLengthDecThm @b (Succ n)+ \\ dropExtensionThm @b @s (Succ n)+ \\ isLongerThanIncThm @b n+ \\ assocThm @(LazyTake n r) @(x : Drop n r) @s+ \\ takeExtensionThm @r @s n \\ dropExtensionThm @r @s n \\ dropHeadThm @x @r n+ \\ dugLengthThm @b @x n++digNExtensionThm+ :: forall s a b x r n. (b ~ x : r, ConstraintDIG n a b x)+ => PeanoNatural n+ -> Dict (ConstraintDIG n (a ++ s) (b ++ s) x)+digNExtensionThm n = Dict+ \\ isLongerThanExtThm @a @s n+ \\ assocThm @(LazyTake n a) @(Drop ('S n) a) @s+ \\ takeExtensionThm @a @s n \\ isLongerOrSameLengthDecThm @a (Succ n)+ \\ dropExtensionThm @a @s (Succ n)+ \\ isLongerThanIncThm @a n+ \\ assocThm @(LazyTake n r) @(x : Drop n r) @s+ \\ takeExtensionThm @r @s n \\ dropExtensionThm @r @s n \\ dropHeadThm @x @r n+ \\ dugLengthThm @a @x n++dipNExtensionThm+ :: forall s a b s1 s1' n. ConstraintDIPN n a b s1 s1'+ => PeanoNatural n+ -> Dict (ConstraintDIPN n (a ++ s) (b ++ s) (s1 ++ s) (s1' ++ s))+dipNExtensionThm n = Dict+ \\ isLongerOrSameLengthExtThm @a @s n+ \\ dropExtensionThm @a @s n+ \\ assocThm @(LazyTake n a) @s1' @s+ \\ takeExtensionThm @a @s n+ \\ assocThm @(LazyTake n a) @s1 @s+ \\ dropExtensionThm @b @s n+ \\ isLongerOrSameLengthExtThm @b @s n+ \\ dipNExtensionLemma @a @b @s1' n++dipNExtensionLemma ::+ forall inp out s n.+ ( RequireLongerOrSameLength inp n+ , LazyTake n inp ++ s ~ out)+ => PeanoNatural n+ -> IsLongerOrSameLength out n :~: 'True+dipNExtensionLemma n = stubProof $ case n of+ Zero -> Refl+ Succ m -> case (assumeKnown @inp, assumeKnown @out) of+ (KCons _ (_ :: Proxy inp'), KCons _ (_ :: Proxy out')) ->+ Refl \\ dipNExtensionLemma @inp' @out' @s m++pairNExtensionThm+ :: forall s a n. (n >= ToPeano 2 ~ 'True, IsLongerOrSameLength a n ~ 'True)+ => PeanoNatural n+ -> Dict (ConstraintPairN n (a ++ s)+ , RightComb (LazyTake n (a ++ s)) ~ RightComb (LazyTake n a)+ , Drop n (a ++ s) ~ (Drop n a ++ s)+ )+pairNExtensionThm n = Dict+ \\ isLongerOrSameLengthExtThm @a @s n+ \\ dropExtensionThm @a @s n+ \\ takeExtensionThm @a @s n++unpairNExtensionThm+ :: forall s a b n x r+ . ( a ~ x : r, CombedPairLeafCountIsAtLeast n x ~ 'True+ , n >= ToPeano 2 ~ 'True, UnpairN n x ++ r ~ b+ )+ => PeanoNatural n+ -> Dict (ConstraintUnpairN n x, UnpairN n x ++ r ++ s ~ b ++ s)+unpairNExtensionThm _ = Dict \\ assocThm @(UnpairN n x) @r @s+ where _ = Dict @(a ~ x : r)
src/Morley/Michelson/Typed/Operation.hs view
@@ -10,13 +10,17 @@ , mkContractAddress , mkOriginationOperationHash , mkTransferOperationHash+ , mkTransferTicketOperationHash , mkDelegationOperationHash ) where +import Data.Binary.Builder qualified as Bi import Data.Binary.Put (putWord64be, runPut) import Data.ByteString.Lazy qualified as BSL +import Morley.Micheline.Binary.Internal (buildInteger) import Morley.Michelson.Interpret.Pack (toBinary, toBinary')+import Morley.Michelson.Runtime.GState (TicketKey(..)) import Morley.Michelson.Runtime.TxData (TxData) import Morley.Michelson.Typed (Emit, EpName(..), Instr, unContractCode) import Morley.Michelson.Typed.Aliases (Contract, Value)@@ -151,6 +155,27 @@ (runPut $ putWord64be $ fromIntegral @Word63 @Word64 $ unMutez amount) <> (toBinary $ toVal (EpAddress to epName)) <> toBinary param++mkTransferTicketOperationHash+ :: TicketKey+ -> Natural+ -> Address+ -> EpName+ -> OperationHash+mkTransferTicketOperationHash (TicketKey (ticketer, contents, ty)) amount dest epName =+ OperationHash $ blake2b packedOperation+ where+ -- In Tezos, ticket transfer operations are encoded as 6-tuple of+ -- (contents, type, ticketer, ticket amount, dest, epName)+ --+ -- See https://gitlab.com/tezos/tezos/-/blob/f7f6047237974ef85d94c87368f2a82615bcc8ca/src/proto_016_PtMumbai/lib_protocol/operation_repr.ml#L1044-1051+ packedOperation =+ BSL.toStrict+ $ toBinary contents+ <> toBinary ty+ <> toBinary (toVal ticketer)+ <> Bi.toLazyByteString (buildInteger (fromIntegral amount))+ <> toBinary (toVal $ EpAddress' dest epName) ---------------------------------------------------------------------------- -- Set Delegate
src/Morley/Michelson/Typed/Scope.hs view
@@ -57,15 +57,6 @@ , ProperNonComparableValBetterErrors , IsDupableScope-- , properParameterEvi- , properStorageEvi- , properConstantEvi- , properDupableEvi- , properPackedValEvi- , properUnpackedValEvi- , properViewableEvi- , properUntypedValEvi , (:-)(..) , BadTypeForScope (..)@@ -94,12 +85,6 @@ , ForbidBigMap , ForbidNestedBigMaps , ForbidNonComparable- , FailOnBigMapFound- , FailOnContractFound- , FailOnNestedBigMapsFound- , FailOnOperationFound- , FailOnTicketFound- , FailOnNonComparableFound , OpPresence (..) , ContractPresence (..)@@ -116,15 +101,14 @@ , contractTypeAbsense , bigMapAbsense , nestedBigMapsAbsense- , forbiddenOp- , forbiddenContractType- , forbiddenBigMap- , forbiddenNestedBigMaps , Comparability(..) , checkComparability , getComparableProofS + , comparabilityImpliesNoNestedBigMaps+ , comparabilityImpliesNoOp+ , getWTP , getWTP' -- * Re-exports@@ -133,17 +117,18 @@ ) where import Data.Bool.Singletons (SBool(..))-import Data.Constraint (Dict(..), withDict, (:-)(..))+import Data.Constraint (Dict(..), withDict, (:-)(..), (\\)) import Data.Singletons (SLambda(..), Sing, SingI(..), fromSing, type (@@), type (~>), type Apply, withSingI, (@@)) import Data.Type.Bool (Not, type (&&), type (||)) import Fmt (Buildable(..))-import GHC.TypeLits (ErrorMessage(..), TypeError)+import GHC.TypeLits (ErrorMessage(..)) import Data.Type.Equality ((:~:)(..)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc) import Morley.Michelson.Typed.Sing (SingT(..)) import Morley.Michelson.Typed.T (T(..))+import Morley.Util.StubbedProof (stubProof) import Morley.Util.Type (FailUnless, FailWhen) import Unsafe.Coerce (unsafeCoerce) @@ -308,51 +293,6 @@ class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t -{-# DEPRECATED- FailOnOperationFound- , FailOnContractFound- , FailOnTicketFound- , FailOnBigMapFound- , FailOnNestedBigMapsFound- , FailOnNonComparableFound- "Use a Forbid* constraint instead"- #-}--- | Report a human-readable error about 'TOperation' at a wrong place.-type family FailOnOperationFound (enabled :: Bool) :: Constraint where- FailOnOperationFound 'True =- TypeError ('Text "Operations are not allowed in this scope")- FailOnOperationFound 'False = ()---- | Report a human-readable error about 'TContract' at a wrong place.-type family FailOnContractFound (enabled :: Bool) :: Constraint where- FailOnContractFound 'True =- TypeError ('Text "Type `contract` is not allowed in this scope")- FailOnContractFound 'False = ()---- | Report a human-readable error about 'TTicket' at a wrong place.-type family FailOnTicketFound (enabled :: Bool) :: Constraint where- FailOnTicketFound 'True =- TypeError ('Text "Type `ticket` is not allowed in this scope")- FailOnTicketFound 'False = ()---- | Report a human-readable error about 'TBigMap' at a wrong place.-type family FailOnBigMapFound (enabled :: Bool) :: Constraint where- FailOnBigMapFound 'True =- TypeError ('Text "BigMaps are not allowed in this scope")- FailOnBigMapFound 'False = ()---- | Report a human-readable error that 'TBigMap' contains another 'TBigMap'-type family FailOnNestedBigMapsFound (enabled :: Bool) :: Constraint where- FailOnNestedBigMapsFound 'True =- TypeError ('Text "Nested BigMaps are not allowed")- FailOnNestedBigMapsFound 'False = ()---- | Report a human-readable error that given value is not comparable-type family FailOnNonComparableFound (comparable :: Bool) :: Constraint where- FailOnNonComparableFound 'True = ()- FailOnNonComparableFound 'False =- TypeError ('Text "Only comparable types are allowed here")- -- | This is like 'HasNoOp', it raises a more human-readable error -- when @t@ type is concrete, and also imposes an equality constraint. --@@ -394,42 +334,6 @@ (IsComparable t) ('Text "Only comparable types are allowed here") -{-# DEPRECATED forbiddenOp, forbiddenBigMap, forbiddenNestedBigMaps, forbiddenContractType- "Simply delete this function wherever it occurs. It is no longer needed."- #-}---- | Deprecated and unused-forbiddenOp- :: forall t a.- ForbidOp t- => (HasNoOp t => a)- -> a-forbiddenOp a = a---- | Deprecated and unused-forbiddenBigMap- :: forall t a.- ForbidBigMap t- => (HasNoBigMap t => a)- -> a-forbiddenBigMap a = a---- | Deprecated and unused-forbiddenNestedBigMaps- :: forall t a.- ForbidNestedBigMaps t- => (HasNoNestedBigMaps t => a)- -> a-forbiddenNestedBigMaps a = a---- | Deprecated and unused-forbiddenContractType- :: forall t a.- ForbidContract t- => (HasNoContract t => a)- -> a-forbiddenContractType a = a- -- | Whether a value of this type _may_ contain an operation. data OpPresence (t :: T) = ContainsOp t ~ 'True => OpPresent@@ -534,7 +438,6 @@ STAddress -> OpAbsent STChest -> OpAbsent STChestKey -> OpAbsent- STTxRollupL2Address -> OpAbsent STNever -> OpAbsent STSaplingState _ -> OpAbsent STSaplingTransaction _ -> OpAbsent@@ -585,7 +488,6 @@ STAddress -> ContractAbsent STChest -> ContractAbsent STChestKey -> ContractAbsent- STTxRollupL2Address -> ContractAbsent STNever -> ContractAbsent STSaplingState _ -> ContractAbsent STSaplingTransaction _ -> ContractAbsent@@ -636,7 +538,6 @@ STAddress -> TicketAbsent STChest -> TicketAbsent STChestKey -> TicketAbsent- STTxRollupL2Address -> TicketAbsent STNever -> TicketAbsent STSaplingState _ -> TicketAbsent STSaplingTransaction _ -> TicketAbsent@@ -687,7 +588,6 @@ STAddress -> BigMapAbsent STChest -> BigMapAbsent STChestKey -> BigMapAbsent- STTxRollupL2Address -> BigMapAbsent STNever -> BigMapAbsent STSaplingState _ -> BigMapAbsent STSaplingTransaction _ -> BigMapAbsent@@ -739,7 +639,6 @@ STAddress -> NestedBigMapsAbsent STChest -> NestedBigMapsAbsent STChestKey -> NestedBigMapsAbsent- STTxRollupL2Address -> NestedBigMapsAbsent STNever -> NestedBigMapsAbsent STSaplingState _ -> NestedBigMapsAbsent STSaplingTransaction _ -> NestedBigMapsAbsent@@ -791,7 +690,6 @@ STAddress -> SaplingStateAbsent STChest -> SaplingStateAbsent STChestKey -> SaplingStateAbsent- STTxRollupL2Address -> SaplingStateAbsent STNever -> SaplingStateAbsent STSaplingState _ -> SaplingStatePresent STSaplingTransaction _ -> SaplingStateAbsent@@ -940,8 +838,8 @@ checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing -- | Alias for comparable types.-type ComparabilityScope t =- (SingI t, Comparable t)+class (SingI t, Comparable t) => ComparabilityScope t+instance (SingI t, Comparable t) => ComparabilityScope t comparabilityPresence :: Sing t -> Maybe (Dict (Comparable t)) comparabilityPresence s = case checkComparability s of@@ -1005,6 +903,12 @@ checkScope = (\Dict -> Dict) <$> checkScope @(Comparable t) +instance (CheckScope a, CheckScope b) => CheckScope (a, b) where+ checkScope = do+ Dict <- checkScope @a+ Dict <- checkScope @b+ pure Dict+ -- | Allows using a scope that can be proven true with a De Morgan law. -- -- Many scopes are defined as @not a@ (or rather @a ~ 'False@) where @a@ is a@@ -1118,8 +1022,6 @@ instance SingI a => WithDeMorganScope HasNoNestedBigMaps 'TOr a b where withDeMorganScope f = simpleWithDeMorgan @ContainsNestedBigMapsSym @a @b f -- instance ( WithDeMorganScope HasNoOp t a b , WithDeMorganScope HasNoNestedBigMaps t a b@@ -1211,35 +1113,6 @@ type ProperNonComparableValBetterErrors t = (SingI t, ForbidNonComparable t) -{-# DEPRECATED properParameterEvi, properStorageEvi, properConstantEvi- , properDupableEvi, properPackedValEvi, properUnpackedValEvi- , properViewableEvi, properUntypedValEvi- "This entailment is now trivial; there is no need to introduce evidence for it."- #-}-properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t-properParameterEvi = Sub Dict--properStorageEvi :: forall t. ProperStorageBetterErrors t :- StorageScope t-properStorageEvi = Sub Dict--properConstantEvi :: forall t. ProperConstantBetterErrors t :- ConstantScope t-properConstantEvi = Sub Dict--properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t-properDupableEvi = Sub Dict--properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t-properPackedValEvi = Sub Dict--properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t-properUnpackedValEvi = Sub Dict--properViewableEvi :: forall t. ProperViewableBetterErrors t :- ViewableScope t-properViewableEvi = Sub Dict--properUntypedValEvi :: forall t. ProperUntypedValBetterErrors t :- UntypedValScope t-properUntypedValEvi = Sub Dict- class (IsComparable t ~ 'True, SingI t, ComparableSuperC t) => Comparable t where -- | Constraints required for instance of a given type. type ComparableSuperC t :: Constraint@@ -1247,11 +1120,11 @@ instance ComparableSuperC ('TPair t1 t2) => Comparable ('TPair t1 t2) where type ComparableSuperC ('TPair t1 t2) =- (Comparable t1, Comparable t2, FailOnNonComparableFound (IsComparable t1 && IsComparable t2))+ (Comparable t1, Comparable t2, ForbidNonComparable t1, ForbidNonComparable t2) instance ComparableSuperC ('TOr t1 t2) => Comparable ('TOr t1 t2) where type ComparableSuperC ('TOr t1 t2) =- (Comparable t1, Comparable t2, FailOnNonComparableFound (IsComparable t1 && IsComparable t2))+ (Comparable t1, Comparable t2, ForbidNonComparable t1, ForbidNonComparable t2) instance ComparableSuperC ('TOption t) => Comparable ('TOption t) where type ComparableSuperC ('TOption t) = (Comparable t, ForbidNonComparable t)@@ -1266,7 +1139,6 @@ instance Comparable 'TKeyHash instance Comparable 'TTimestamp instance Comparable 'TAddress-instance Comparable 'TTxRollupL2Address instance Comparable 'TNever instance Comparable 'TChainId instance Comparable 'TSignature@@ -1291,7 +1163,6 @@ instance WellTyped 'TChainId instance WellTyped 'TChest instance WellTyped 'TChestKey-instance WellTyped 'TTxRollupL2Address instance WellTypedSuperC ('TOption t) => WellTyped ('TOption t) where type WellTypedSuperC ('TOption t) = WellTyped t@@ -1429,7 +1300,6 @@ STAddress -> Right Dict STChest -> Right Dict STChestKey -> Right Dict- STTxRollupL2Address -> Right Dict STNever -> Right Dict STSaplingState s -> withSingI s $ Right Dict STSaplingTransaction s -> withSingI s $ Right Dict@@ -1486,6 +1356,61 @@ STChainId -> CanBeCompared STChest -> CannotBeCompared STChestKey -> CannotBeCompared- STTxRollupL2Address -> CanBeCompared STSaplingState _ -> CannotBeCompared STSaplingTransaction _ -> CannotBeCompared++-- | Inductive proof that 'Comparable' implies 'HasNoNestedBigMaps'. This is+-- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.+comparabilityImpliesNoNestedBigMaps+ :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsNestedBigMaps t :~: 'False+comparabilityImpliesNoNestedBigMaps = stubProof $ go (sing @t)+ where+ go :: IsComparable a ~ 'True => Sing a -> ContainsNestedBigMaps a :~: 'False+ go = \case+ STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b+ STOr a b -> case (checkComparability a, checkComparability b) of+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b+ STOption t -> Refl \\ go t+ STNever -> Refl+ STUnit -> Refl+ STInt -> Refl+ STNat -> Refl+ STString -> Refl+ STBytes -> Refl+ STMutez -> Refl+ STBool -> Refl+ STKeyHash -> Refl+ STTimestamp -> Refl+ STAddress -> Refl+ STKey -> Refl+ STSignature -> Refl+ STChainId -> Refl++-- | Inductive proof that 'Comparable' implies 'HasNoOp'. This is+-- stubbed with an @unsafeCoerce Refl@ at runtime to avoid runtime traversals.+comparabilityImpliesNoOp+ :: forall t. (SingI t, IsComparable t ~ 'True) => ContainsOp t :~: 'False+comparabilityImpliesNoOp = stubProof $ go (sing @t)+ where+ go :: IsComparable a ~ 'True => Sing a -> ContainsOp a :~: 'False+ go = \case+ STPair (a :: Sing a) (b :: Sing b) -> case (checkComparability a, checkComparability b) of+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b+ STOr a b -> case (checkComparability a, checkComparability b) of+ (CanBeCompared, CanBeCompared) -> Refl \\ go a \\ go b+ STOption t -> Refl \\ go t+ STNever -> Refl+ STUnit -> Refl+ STInt -> Refl+ STNat -> Refl+ STString -> Refl+ STBytes -> Refl+ STMutez -> Refl+ STBool -> Refl+ STKeyHash -> Refl+ STTimestamp -> Refl+ STAddress -> Refl+ STKey -> Refl+ STSignature -> Refl+ STChainId -> Refl
src/Morley/Michelson/Typed/T.hs view
@@ -51,7 +51,6 @@ | TChestKey | TSaplingState Peano.Peano | TSaplingTransaction Peano.Peano- | TTxRollupL2Address | TNever deriving stock (Eq, Show, Generic, Data) @@ -80,7 +79,6 @@ convert TChainId = Un.TChainId convert TChest = Un.TChest convert TChestKey = Un.TChestKey- convert TTxRollupL2Address = Un.TTxRollupL2Address convert TNever = Un.TNever convert (TSaplingState n) = Un.TSaplingState (Peano.toNatural n) convert (TSaplingTransaction n) = Un.TSaplingTransaction (Peano.toNatural n)
src/Morley/Michelson/Typed/Util.hs view
@@ -38,7 +38,6 @@ , instrAnns ) where -import Debug qualified (show) import Prelude hiding (Ordering(..)) import Control.Monad.Writer.Strict (Writer, execWriterT, runWriter, tell, writer)@@ -131,7 +130,6 @@ SOneChild -> \case C_WithLoc loc i1 -> recursion1 (WithLoc loc) i1 C_Meta meta i1 -> recursion1 (Meta meta) i1- C_FrameInstr p i1 -> recursion1 (FrameInstr p) i1 C_Nested i1 -> recursion1 Nested i1 C_DocGroup dg i1 -> recursion1 (DocGroup dg) i1 C_AnnMAP ann i1 -> recursion1 (AnnMAP ann) i1@@ -153,17 +151,17 @@ recursion1 (AnnLAMBDA ann . analyzeInstrFailure) (rfAnyInstr i1) C_AnnLAMBDA_REC ann i1 -> recursion1 (AnnLAMBDA_REC ann . analyzeInstrFailure) (rfAnyInstr i1)- C_AnnCREATE_CONTRACT ann contract ->+ C_AnnCREATE_CONTRACT ann contract@Contract{..} -> ceaPostStep dsCtorEffectsApp i- case cCode contract of+ case cCode of ContractCode c -> do codeI <- dfsTraverseInstr settings c- viewsI <- forM (toList $ cViews contract) \(SomeView v) -> do- code <- dfsTraverseInstr settings $ vCode v- return $ SomeView v{ vCode = code }+ viewsI <- forM (unViewsSet cViews) \(SomeView v@View{..}) -> do+ code <- dfsTraverseInstr settings vCode+ pure $ SomeView v{ vCode = code } dsInstrStep $ AnnCREATE_CONTRACT ann $ contract { cCode = ContractCode codeI- , cViews = UnsafeViewsSet $ fromList viewsI+ , cViews = UnsafeViewsSet viewsI } | otherwise -> const $ recursion0 i SNoChildren -> const $ recursion0 i@@ -225,7 +223,7 @@ -- Often we already have information about instruction failure, use this -- function only in cases when this info is actually unavailable or hard -- to use.-analyzeInstrFailure :: HasCallStack => Instr i o -> RemFail Instr i o+analyzeInstrFailure :: Instr i o -> RemFail Instr i o analyzeInstrFailure = go where go :: Instr i o -> RemFail Instr i o@@ -249,11 +247,6 @@ _ -> \case C_WithLoc loc i -> WithLoc loc `rfMapAnyInstr` go i C_Meta meta i -> Meta meta `rfMapAnyInstr` go i- C_FrameInstr s i -> case go i of- RfNormal i0 ->- RfNormal (FrameInstr s i0)- RfAlwaysFails i0 ->- error $ "FrameInstr wraps always-failing instruction: " <> Debug.show i0 C_Nested i -> Nested `rfMapAnyInstr` go i C_DocGroup g i -> DocGroup g `rfMapAnyInstr` go i @@ -341,7 +334,6 @@ VAddress{} -> dsValueStep i VChestKey{} -> dsValueStep i VChest{} -> dsValueStep i- VTxRollupL2Address{} -> dsValueStep i -- Non-atomic VOption mVal -> case mVal of@@ -508,7 +500,6 @@ VAddress{} -> ConstantStorage v VChest{} -> ConstantStorage v VChestKey{} -> ConstantStorage v- VTxRollupL2Address{} -> ConstantStorage v VTicket{} -> PartlyPushableStorage v Nop -- Non-atomic
src/Morley/Michelson/Typed/Value.hs view
@@ -206,7 +206,6 @@ tcompare (VChainId a) (VChainId b) = compare a b tcompare (VSignature a) (VSignature b) = compare a b tcompare (VKey a) (VKey b) = compare a b-tcompare (VTxRollupL2Address a) (VTxRollupL2Address b) = compare a b instance (Comparable t) => Ord (Value' instr t) where compare = tcompare @t@@ -283,7 +282,6 @@ VBls12381G2 :: Bls12381G2 -> Value' instr 'TBls12381G2 VChest :: Chest -> Value' instr 'TChest VChestKey :: ChestKey -> Value' instr 'TChestKey- VTxRollupL2Address :: TxRollupL2Address -> Value' instr 'TTxRollupL2Address deriving stock instance Show (Value' instr t) deriving stock instance Eq (Value' instr t)@@ -379,7 +377,6 @@ VAddress{} -> Dict VChest{} -> Dict VChestKey{} -> Dict- VTxRollupL2Address{} -> Dict mkVLam :: ( SingI inp, SingI out
src/Morley/Michelson/Typed/View.hs view
@@ -7,17 +7,19 @@ -- | Module, containing on-chain views declarations. module Morley.Michelson.Typed.View ( -- * View- ViewName (..)+ ViewName (ViewName, ..)+ , BadViewNameError (..) , mkViewName , viewNameToMText+ , ViewCode' , View' (..) , SomeView' (..) , someViewName -- * Views set- , ViewsSet' (.., ViewsSet, ViewsList)- , ViewsSetError (..)+ , ViewsSet' (.., ViewsList)+ , VS.ViewsSetError (..) , mkViewsSet , emptyViewsSet , addViewToSet@@ -26,18 +28,16 @@ , SomeViewsSet' (..) ) where -import Control.Monad.Except (throwError)+import Data.Coerce (coerce) import Data.Default (Default(..))-import Data.Sequence qualified as Seq-import Fmt (Buildable(..), (+|), (|+)) +import Morley.Michelson.Internal.ViewName+import Morley.Michelson.Internal.ViewsSet qualified as VS import Morley.Michelson.Typed.Annotation import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.T (T(..))-import Morley.Michelson.Untyped.View (ViewName(..), mkViewName, viewNameToMText) import Morley.Util.Sing - type ViewCode' instr arg st ret = instr '[ 'TPair arg st] '[ret] -- | Contract view.@@ -80,13 +80,7 @@ ---------------------------------------------------------------------------- -- | Views that belong to one contract.------ Invariant: all view names are unique.------ Implementation note: lookups still take linear time.--- We use 'Seq' for simplicity, as in either case we need to preserve the order--- of views (so that decoding/encoding roundtrip).-newtype ViewsSet' instr st = UnsafeViewsSet { unViewsSet :: Seq $ SomeView' instr st }+newtype ViewsSet' instr st = UnsafeViewsSet { unViewsSet :: Map ViewName (SomeView' instr st) } deriving newtype (Default, Container) deriving stock instance@@ -98,56 +92,34 @@ instance (forall i o. NFData (instr i o)) => NFData (ViewsSet' instr st) where- rnf (ViewsSet vs) = rnf vs--pattern ViewsSet :: Seq (SomeView' instr st) -> ViewsSet' instr st-pattern ViewsSet views <- UnsafeViewsSet views-{-# COMPLETE ViewsSet #-}+ rnf (UnsafeViewsSet vs) = rnf vs pattern ViewsList :: [SomeView' instr st] -> ViewsSet' instr st-pattern ViewsList views <- ViewsSet (toList -> views)+pattern ViewsList views <- UnsafeViewsSet (toList -> views) {-# COMPLETE ViewsList #-} --- | Errors possible when constructing 'ViewsSet\''.-data ViewsSetError- = DuplicatedViewName ViewName- deriving stock (Show, Eq)--instance Buildable ViewsSetError where- build = \case- DuplicatedViewName name -> "Duplicated view name '" +| name |+ "'"- -- | Construct views set.-mkViewsSet :: [SomeView' instr st] -> Either ViewsSetError (ViewsSet' instr st)-mkViewsSet views = do- forM_ (group . sort $ map someViewName views) $ \case- name : _ : _ -> throwError $ DuplicatedViewName name- _ : _ -> pass- [] -> error "impossible"- pure (UnsafeViewsSet $ fromList views)+mkViewsSet :: [SomeView' instr st] -> Either VS.ViewsSetError (ViewsSet' instr st)+mkViewsSet = coerce ... VS.mkViewsSet someViewName -- | No views.-emptyViewsSet :: ViewsSet' instr st-emptyViewsSet = UnsafeViewsSet mempty+emptyViewsSet :: forall instr st. ViewsSet' instr st+emptyViewsSet = coerce $ VS.emptyViewsSet @(SomeView' instr st) -- | Add a view to set. addViewToSet :: View' instr arg st ret -> ViewsSet' instr st- -> Either ViewsSetError (ViewsSet' instr st)-addViewToSet v views = do- when (vName v `elem` viewsSetNames views) $- throwError $ DuplicatedViewName (vName v)- return (UnsafeViewsSet $ unViewsSet views Seq.|> SomeView v)+ -> Either VS.ViewsSetError (ViewsSet' instr st)+addViewToSet = coerce . VS.addViewToSet someViewName . SomeView -- | Find a view in the set.-lookupView :: ViewName -> ViewsSet' instr st -> Maybe (SomeView' instr st)-lookupView name (ViewsSet views) =- find (\(SomeView View{..}) -> vName == name) views+lookupView :: forall instr st. ViewName -> ViewsSet' instr st -> Maybe (SomeView' instr st)+lookupView = coerce . VS.lookupView @(SomeView' instr st) -- | Get all taken names in views set.-viewsSetNames :: ViewsSet' instr st -> [ViewName]-viewsSetNames = map someViewName . toList+viewsSetNames :: forall instr st. ViewsSet' instr st -> Set ViewName+viewsSetNames = VS.viewsSetNames @(SomeView' instr st) . coerce data SomeViewsSet' instr where SomeViewsSet :: SingI st => ViewsSet' instr st -> SomeViewsSet' instr
src/Morley/Michelson/Untyped/Contract.hs view
@@ -5,9 +5,10 @@ module Morley.Michelson.Untyped.Contract ( EntriesOrder (..)+ , Entry(..) , canonicalEntriesOrder- , entriesOrderToInt , mapEntriesOrdered+ , mkEntriesOrder , ContractBlock (..) , orderContractBlock@@ -18,11 +19,17 @@ , mapContractCode ) where +import Control.Lens (folded, makePrisms)+import Data.Aeson (FromJSON, FromJSONKey(..), ToJSON, ToJSONKey(..)) import Data.Aeson.TH (deriveJSON)+import Data.Aeson.Types qualified as AesonTypes import Data.Data (Data(..)) import Data.Default (Default(..))-import Fmt (Buildable(build))-import Text.PrettyPrint.Leijen.Text (indent, nest, semi, text, (<$$>), (<+>))+import Data.Map qualified as Map+import Data.Text (stripPrefix)+import Fmt (Buildable(build), pretty)+import Text.PrettyPrint.Leijen.Text (nest, semi, text, (<$$>), (<+>))+import Text.PrettyPrint.Leijen.Text qualified as PP import Morley.Michelson.Printer.Util (Prettier(..), RenderDoc(..), assertParensNotNeeded, buildRenderDoc, needsParens, renderOpsList)@@ -30,45 +37,52 @@ import Morley.Michelson.Untyped.View import Morley.Util.Aeson --- TODO [#698]: views are yet handled in a very hacky and not fully working way+data Entry+ = EntryParameter+ | EntryStorage+ | EntryCode+ | EntryView ViewName+ deriving stock (Eq, Ord, Show, Data, Generic) +deriveJSON morleyAesonOptions ''Entry++instance ToJSONKey Entry where+ toJSONKey = AesonTypes.toJSONKeyText $ \case+ EntryParameter -> "parameter"+ EntryStorage -> "storage"+ EntryCode -> "code"+ EntryView name -> "view:" <> unViewName name++instance FromJSONKey Entry where+ fromJSONKey = AesonTypes.FromJSONKeyTextParser $ \case+ "parameter" -> pure EntryParameter+ "storage" -> pure EntryStorage+ "code" -> pure EntryCode+ x | Just name <- stripPrefix "view:" x+ -> either (fail . pretty) (pure . EntryView) $ mkViewName name+ _ -> fail $ "Unexpected Entry value"++instance NFData Entry+ -- | Top-level entries order of the contract. -- This is preserved due to the fact that it affects -- the output of pretty-printing and serializing contract.+newtype EntriesOrder = EntriesOrder { unEntriesOrder :: Map Entry Word }+ deriving stock (Eq, Ord, Show, Data)+ deriving newtype (NFData, FromJSON, ToJSON) --- Each constructors is created by the order of the first letter of--- @parameter@, @storage@, and @code@.------ For example, @PSC@ would be @parameter@, @storage@ and @code@,--- @CPS@ would be @code@, @parameter@,and @storage@, and so on.-data EntriesOrder- = PSC- | PCS- | SPC- | SCP- | CSP- | CPS- deriving stock (Bounded, Data, Enum, Eq, Generic, Show)+-- | Helper to construct 'EntriesOrder' from an ordered list of entires.+-- Duplicate entires are ignored.+mkEntriesOrder :: [Entry] -> EntriesOrder+mkEntriesOrder = EntriesOrder . Map.fromListWith const . (`zip` [0..]) instance Default EntriesOrder where def = canonicalEntriesOrder-instance NFData EntriesOrder -- | The canonical entries order which is ordered as follow: -- @parameter@, @storage@, and @code@. canonicalEntriesOrder :: EntriesOrder-canonicalEntriesOrder = PSC---- | @(Int, Int, Int)@ is the positions of @parameter@, @storage@, and @code@--- respectively.-entriesOrderToInt :: EntriesOrder -> (Int, Int, Int)-entriesOrderToInt = \case- PSC -> (0, 1, 2)- PCS -> (0, 2, 1)- SPC -> (1, 0, 2)- SCP -> (1, 2, 0)- CSP -> (2, 1, 0)- CPS -> (2, 0, 1)+canonicalEntriesOrder = mkEntriesOrder [EntryParameter, EntryStorage, EntryCode] -- | Contract block, convenient when parsing data ContractBlock op@@ -78,30 +92,37 @@ | CBView (View' op) deriving stock (Eq, Show, Functor) +makePrisms ''ContractBlock+ -- | Construct a contract representation from the contract blocks (i.e. parameters, -- storage, code blocks, etc.) in arbitrary order. -- This makes sure that unique blocks like @code@ do not duplicate, and saves the -- order in the contract so that it can print the contract blocks in the same--- order it was parsed. TODO [#698]: this is not fully true now.+-- order it was parsed. orderContractBlock :: [ContractBlock op] -> Maybe (Contract' op) orderContractBlock blocks = let- vs = mapMaybe (\case CBView v -> Just v; _ -> Nothing) blocks- plain = filter (\case CBView{} -> False; _ -> True) blocks- in case plain of- [CBParam p, CBStorage s, CBCode c] -> Just $ Contract p s c PSC vs- [CBParam p, CBCode c, CBStorage s] -> Just $ Contract p s c PCS vs- [CBStorage s, CBParam p, CBCode c] -> Just $ Contract p s c SPC vs- [CBStorage s, CBCode c, CBParam p] -> Just $ Contract p s c SCP vs- [CBCode c, CBStorage s, CBParam p] -> Just $ Contract p s c CSP vs- [CBCode c, CBParam p, CBStorage s] -> Just $ Contract p s c CPS vs- _ -> Nothing+ -- we are sure there are no duplicate view names due to the guard below, so+ -- we can construct a Map right away+ contractViews = unsafe . mkViewsSet $ blocks ^.. folded . _CBView+ blockTypes = blocks <&> \case+ CBParam{} -> EntryParameter+ CBStorage{} -> EntryStorage+ CBCode{} -> EntryCode+ CBView View{..} -> EntryView viewName+ entriesOrder = mkEntriesOrder blockTypes+ in do+ guard $ blockTypes == ordNub blockTypes -- must have no duplicates+ contractParameter <- blocks ^? folded . _CBParam+ contractStorage <- blocks ^? folded . _CBStorage+ contractCode <- blocks ^? folded . _CBCode+ pure Contract{..} instance Buildable (ContractBlock op) where- build (CBParam{}) = "parameter"- build (CBStorage{}) = "storage"- build (CBCode{}) = "code"- build (CBView{}) = "view"+ build CBParam{} = "parameter"+ build CBStorage{} = "storage"+ build CBCode{} = "code"+ build (CBView View{..}) = "view \"" <> build viewName <> "\"" -- | Map each contract fields by the given function and sort the output -- based on the 'EntriesOrder'.@@ -112,17 +133,15 @@ -> ([op] -> a) -> (View' op -> a) -> [a]-mapEntriesOrdered Contract{..} fParam fStorage fCode fView =- mconcat- [ fmap snd $ sortWith fst- [ (paramPos, fParam contractParameter)- , (storagePos, fStorage contractStorage)- , (codePos, fCode contractCode)- ]- , fmap fView contractViews- ]+mapEntriesOrdered Contract{..} fParam fStorage fCode fView = snd <$> sortWith fst elements where- (paramPos, storagePos, codePos) = entriesOrderToInt entriesOrder+ getElemOrder ty = fromMaybe maxBound $ Map.lookup ty $ unEntriesOrder entriesOrder+ elements+ = first getElemOrder+ <$> [ (EntryParameter, fParam contractParameter)+ , (EntryStorage, fStorage contractStorage)+ , (EntryCode, fCode contractCode)]+ <> (toList contractViews <&> \v@View{..} -> (EntryView viewName, fView v)) -- | Convenience synonym for 'Ty' representing the storage type type Storage = Ty@@ -138,7 +157,7 @@ , entriesOrder :: EntriesOrder -- ^ Original order of contract blocks, so that we can print them -- in the same order they were read- , contractViews :: [View' op]+ , contractViews :: ViewsSet op -- ^ Contract views } deriving stock (Eq, Show, Functor, Data, Generic) @@ -152,26 +171,21 @@ (\parameter -> "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi) (\storage -> "storage" <+> renderDoc needsParens (Prettier storage) <> semi) (\code -> "code" <+> nest (length ("code {" :: Text)) (renderOpsList False code <> semi))- (\View{..} -> "view" <+> renderViewName viewName- <+> renderDoc needsParens viewArgument- <+> renderDoc needsParens viewReturn- <$$> indent 5 -- 5 is forced by Michelson- (renderOpsList False viewCode)- <> semi- )+ (\View{..} -> PP.group $ "view" <+> PP.align (+ PP.sep+ [ renderViewName viewName+ , renderDoc needsParens viewArgument+ , renderDoc needsParens viewReturn+ ]+ PP.<$> renderOpsList False viewCode <> semi+ )) instance RenderDoc op => Buildable (Contract' op) where build = buildRenderDoc -- | Map all the instructions appearing in the contract. mapContractCode :: (op -> op) -> Contract' op -> Contract' op-mapContractCode f (Contract param st code o vs) =- Contract- param- st- (code <&> f)- o- (vs <&> \v -> v{ viewCode = viewCode v <&> f })+mapContractCode f = fmap f+{-# DEPRECATED mapContractCode "Use fmap instead" #-} -deriveJSON morleyAesonOptions ''EntriesOrder deriveJSON morleyAesonOptions ''Contract'
src/Morley/Michelson/Untyped/Instr.hs view
@@ -16,8 +16,7 @@ import Data.Data (Data(..)) import Fmt (Buildable(build), (+|), (|+)) import Generics.SYB (everywhere, mkT)-import Text.PrettyPrint.Leijen.Text- (Doc, align, braces, enclose, group, indent, integer, nest, space, text, (<$$>), (<+>))+import Text.PrettyPrint.Leijen.Text (Doc, align, braces, enclose, group, integer, space, (<+>)) import Text.PrettyPrint.Leijen.Text qualified as PP import Morley.Michelson.ErrorPos (ErrorSrcPos)@@ -216,6 +215,8 @@ | SAPLING_VERIFY_UPDATE VarAnn | MIN_BLOCK_TIME [AnyAnn] | EMIT VarAnn FieldAnn (Maybe Ty)+ | BYTES VarAnn+ | NAT VarAnn deriving stock (Eq, Functor, Data, Generic, Show) instance NFData op => NFData (InstrAbstract op)@@ -224,67 +225,60 @@ renderDoc pn = \case EXT extInstr -> renderDoc pn extInstr DROP -> "DROP"- DROPN n -> "DROP" <+> text (show n)+ DROPN n -> "DROP" <+> integral n DUP va -> "DUP" <+> renderAnnot va- DUPN va n -> "DUP" <+> renderAnnot va <+> text (show n)+ DUPN va n -> "DUP" <+> renderAnnot va <+> integral n SWAP -> "SWAP"- DIG n -> "DIG" <+> text (show n)- DUG n -> "DUG" <+> text (show n)+ DIG n -> "DIG" <+> integral n+ DUG n -> "DUG" <+> integral n PUSH va t v ->- group $ nest 2 $- text "PUSH" <+> renderAnnot va- PP.<$> renderTy t- PP.<$> renderDoc needsParens v+ renderArgs "PUSH" (renderAnnot va) [renderTy t, renderDoc needsParens v] SOME ta va -> "SOME" <+> renderAnnots [ta] [] [va]- NONE ta va t -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t+ NONE ta va t -> renderArgs "NONE" (renderAnnots [ta] [] [va]) [renderTy t] UNIT ta va -> "UNIT" <+> renderAnnots [ta] [] [va]- IF_NONE x y -> "IF_NONE" <+> PP.align (renderOps x PP.<$> renderOps y)+ IF_NONE x y -> renderArgs "IF_NONE" mempty [renderOps x, renderOps y] PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va] UNPAIR va1 va2 fa1 fa2 -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]- PAIRN va n -> "PAIR" <+> renderAnnots [] [] [va] <+> text (show n)- UNPAIRN n -> "UNPAIR" <+> text (show n)+ PAIRN va n -> "PAIR" <+> renderAnnots [] [] [va] <+> integral n+ UNPAIRN n -> "UNPAIR" <+> integral n CAR va fa -> "CAR" <+> renderAnnots [] [fa] [va] CDR va fa -> "CDR" <+> renderAnnots [] [fa] [va]- LEFT ta va fa1 fa2 t -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t- RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t- IF_LEFT x y -> "IF_LEFT" <+> PP.align (renderOps x PP.<$> renderOps y)- NIL ta va t -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t+ LEFT ta va fa1 fa2 t -> renderArgs "LEFT" (renderAnnots [ta] [fa1, fa2] [va]) [renderTy t]+ RIGHT ta va fa1 fa2 t -> renderArgs "RIGHT" (renderAnnots [ta] [fa1, fa2] [va]) [renderTy t]+ IF_LEFT x y -> renderArgs "IF_LEFT" mempty [renderOps x, renderOps y]+ NIL ta va t -> renderArgs "NIL" (renderAnnots [ta] [] [va]) [renderTy t] CONS va -> "CONS" <+> renderAnnot va- IF_CONS x y -> "IF_CONS" <+> PP.align (renderOps x PP.<$> renderOps y)+ IF_CONS x y -> renderArgs "IF_CONS" mempty [renderOps x, renderOps y] SIZE va -> "SIZE" <+> renderAnnot va- EMPTY_SET ta va t -> "EMPTY_SET" <+> renderAnnots [ta] [] [va] <+> renderComp t- EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t- EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t- MAP va s -> "MAP" <+> PP.align (renderAnnot va PP.<$> renderOps s)- ITER s -> "ITER" <+> PP.align (renderOps s)+ EMPTY_SET ta va t -> renderArgs "EMPTY_SET" (renderAnnots [ta] [] [va]) [renderComp t]+ EMPTY_MAP ta va c t ->+ renderArgs "EMPTY_MAP" (renderAnnots [ta] [] [va]) [renderComp c, renderTy t]+ EMPTY_BIG_MAP ta va c t ->+ renderArgs "EMPTY_BIG_MAP" (renderAnnots [ta] [] [va]) [renderComp c, renderTy t]+ MAP va s -> renderArgs "MAP" (renderAnnot va) [renderOps s]+ ITER s -> renderArgs "ITER" mempty [renderOps s] MEM va -> "MEM" <+> renderAnnot va GET va -> "GET" <+> renderAnnot va- GETN va n -> "GET" <+> renderAnnot va <+> text (show n)+ GETN va n -> "GET" <+> renderAnnot va <+> integral n UPDATE va -> "UPDATE" <+> renderAnnot va- UPDATEN va n -> "UPDATE" <+> renderAnnot va <+> text (show n)+ UPDATEN va n -> "UPDATE" <+> renderAnnot va <+> integral n GET_AND_UPDATE va -> "GET_AND_UPDATE" <+> renderAnnot va- IF x y -> "IF" <+> PP.align (renderOps x PP.<$> renderOps y)- LOOP s -> "LOOP" <+> PP.align (renderOps s)- LOOP_LEFT s -> "LOOP_LEFT" <+> PP.align (renderOps s)+ IF x y -> renderArgs "IF" mempty [renderOps x, renderOps y]+ LOOP s -> renderArgs "LOOP" mempty [renderOps s]+ LOOP_LEFT s -> renderArgs "LOOP_LEFT" mempty [renderOps s] LAMBDA va t r s ->- nest 2 $ "LAMBDA" <+> renderAnnot va- PP.<$> renderTy t- PP.<$> renderTy r- PP.<$> renderOps s+ renderArgs "LAMBDA" (renderAnnot va) [renderTy t, renderTy r, renderOps s] LAMBDA_REC va t r s ->- nest 2 $ "LAMBDA_REC" <+> renderAnnot va- PP.<$> renderTy t- PP.<$> renderTy r- PP.<$> renderOps s+ renderArgs "LAMBDA_REC" (renderAnnot va) [renderTy t, renderTy r, renderOps s] EXEC va -> "EXEC" <+> renderAnnot va APPLY va -> "APPLY" <+> renderAnnot va- DIP s -> "DIP" <+> PP.align (renderOps s)- DIPN n s -> "DIP" <+> PP.align (text (show n) PP.<$> renderOps s)+ DIP s -> renderArgs "DIP" mempty [renderOps s]+ DIPN n s -> renderArgs "DIP" mempty [integral n, renderOps s] FAILWITH -> "FAILWITH"- CAST va t -> "CAST" <+> renderAnnot va <+> renderTy t+ CAST va t -> renderArgs "CAST" (renderAnnot va) [renderTy t] RENAME va -> "RENAME" <+> renderAnnot va PACK va -> "PACK" <+> renderAnnot va- UNPACK ta va t -> "UNPACK" <+> renderAnnots [ta] [] [va] <+> renderTy t+ UNPACK ta va t -> renderArgs "UNPACK" (renderAnnots [ta] [] [va]) [renderTy t] CONCAT va -> "CONCAT" <+> renderAnnot va SLICE va -> "SLICE" <+> renderAnnot va ISNAT va -> "ISNAT" <+> renderAnnot va@@ -309,14 +303,15 @@ LE va -> "LE" <+> renderAnnot va GE va -> "GE" <+> renderAnnot va INT va -> "INT" <+> renderAnnot va- VIEW va name ty -> "VIEW" <+> renderAnnot va <+> renderViewName name <+> renderTy ty+ VIEW va name ty ->+ renderArgs "VIEW" (renderAnnot va) [renderViewName name, renderTy ty] SELF va fa -> "SELF" <+> renderAnnots [] [fa] [va]- CONTRACT va fa t -> "CONTRACT" <+> renderAnnots [] [fa] [va] <+> renderTy t+ CONTRACT va fa t -> renderArgs "CONTRACT" (renderAnnots [] [fa] [va]) [renderTy t] TRANSFER_TOKENS va -> "TRANSFER_TOKENS" <+> renderAnnot va SET_DELEGATE va -> "SET_DELEGATE" <+> renderAnnot va CREATE_CONTRACT va1 va2 contract -> let- body = enclose space space $ align $ (renderDoc doesntNeedParens contract)- in "CREATE_CONTRACT" <+> renderAnnots [] [] [va1, va2] <$$> (indent 2 $ braces $ body)+ body = enclose space space $ align $ renderDoc doesntNeedParens contract+ in renderArgs "CREATE_CONTRACT" (renderAnnots [] [] [va1, va2]) [braces $ body] IMPLICIT_ACCOUNT va -> "IMPLICIT_ACCOUNT" <+> renderAnnot va NOW va -> "NOW" <+> renderAnnot va AMOUNT va -> "AMOUNT" <+> renderAnnot va@@ -344,10 +339,13 @@ SPLIT_TICKET va -> "SPLIT_TICKET" <+> renderAnnot va JOIN_TICKETS va -> "JOIN_TICKETS" <+> renderAnnot va OPEN_CHEST va -> "OPEN_CHEST" <+> renderAnnot va- EMIT va fa ty -> "EMIT" <+> renderAnnots [] [fa] [va] <+> maybe mempty renderTy ty- SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> (integer $ toInteger n)+ EMIT va fa ty ->+ renderArgs "EMIT" (renderAnnots [] [fa] [va]) $ maybeToList $ renderTy <$> ty+ SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> integral n SAPLING_VERIFY_UPDATE va -> "SAPLING_VERIFY_UPDATE" <+> renderAnnot va MIN_BLOCK_TIME anns -> "MIN_BLOCK_TIME" <+> renderAnyAnns anns+ BYTES va -> "BYTES" <+> renderAnnot va+ NAT va -> "NAT" <+> renderAnnot va where renderTy = renderDoc @Ty needsParens renderComp = renderDoc @Ty needsParens@@ -358,6 +356,16 @@ renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs++ integral :: Integral a => a -> Doc+ integral = integer . toInteger++ renderArgs :: Text -> Doc -> [Doc] -> Doc+ renderArgs name annots args+ | PP.isEmpty annots && length name <= 3+ = group $ PP.textStrict name <+> annots <+> PP.align (PP.vsep args)+ | otherwise+ = group $ PP.hang 2 $ PP.vsep $ PP.textStrict name <+> annots : args isRenderable = \case EXT extInstr -> isRenderable extInstr
src/Morley/Michelson/Untyped/Type.hs view
@@ -42,7 +42,8 @@ import Fmt (Buildable(build)) import Language.Haskell.TH.Syntax (Lift) import Prelude hiding ((<$>))-import Text.PrettyPrint.Leijen.Text (Doc, align, integer, softbreak, (<$>), (<+>))+import Text.PrettyPrint.Leijen.Text (Doc, integer, (<+>))+import Text.PrettyPrint.Leijen.Text qualified as PP import Morley.Michelson.Printer.Util (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, buildRenderDocExtended,@@ -114,11 +115,11 @@ renderType t forceSingleLine pn annSet = let annDoc = renderDoc doesntNeedParens annSet recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'- renderBranches :: NonEmpty Doc -> Doc- renderBranches ds =- if forceSingleLine- then foldl1 (<+>) ds- else align $ softbreak <> foldl1 (<$>) ds+ renderParametric :: Text -> [Doc] -> Doc+ renderParametric name args = PP.group $+ if PP.isEmpty annDoc && length name < 3+ then addParens pn $ PP.textStrict name <+> PP.align (PP.vsep args)+ else PP.hang 2 $ addParens pn $ PP.vsep $ PP.textStrict name <+> annDoc : args collectBranches :: T -> TypeAnn -> FieldAnn -> NonEmpty Doc collectBranches (TPair fa1 fa2 va1 _ (Ty t1 ta1) (Ty t2 ta2)) _ (Annotation "")@@ -149,76 +150,56 @@ TNever -> wrapInParens pn $ "never" :| [annDoc] TSaplingState n -> addParens pn $ "sapling_state" <+> annDoc <+> (integer $ toInteger n) TSaplingTransaction n -> addParens pn $ "sapling_transaction" <+> annDoc <+> (integer $ toInteger n)- TTxRollupL2Address -> wrapInParens pn $ "tx_rollup_l2_address" :| [annDoc] TOption (Ty t1 ta1) ->- addParens pn $- "option" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)+ renderParametric "option" [recRenderer t1 (singleAnnSet ta1)] TList (Ty t1 ta1) ->- addParens pn $- "list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)+ renderParametric "list" [recRenderer t1 (singleAnnSet ta1)] TSet (Ty t1 ta1) ->- addParens pn $- "set" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)+ renderParametric "set" [recRenderer t1 (singleAnnSet ta1)] TContract (Ty t1 ta1) ->- addParens pn $- "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)+ renderParametric "contract" [recRenderer t1 (singleAnnSet ta1)] TTicket (Ty t1 ta1) ->- addParens pn $- "ticket" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)+ renderParametric "ticket" [recRenderer t1 (singleAnnSet ta1)] -- Optimize in comb pair rendering: `pair x y z` instead of `pair x (pair y z)` -- Works only if there is no field annotation on nested pair p@(TPair _ (Annotation "") _ _ (Ty _ _) (Ty (TPair {}) _)) ->- let branches = collectBranches p noAnn noAnn- in- addParens pn $- "pair" <+> annDoc <+>- renderBranches branches+ renderParametric "pair" $ toList $ collectBranches p noAnn noAnn TPair fa1 fa2 va1 va2 (Ty t1 ta1) (Ty t2 ta2) ->- addParens pn $- "pair" <+> annDoc <+>- renderBranches (- (recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1]) :|- [ recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2]- ])+ renderParametric "pair"+ [ recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1]+ , recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2]+ ] TOr fa1 fa2 (Ty t1 ta1) (Ty t2 ta2) ->- addParens pn $- "or" <+> annDoc <+>- renderBranches (- (recRenderer t1 $ fullAnnSet [ta1] [fa1] []) :|- [ recRenderer t2 $ fullAnnSet [ta2] [fa2] []- ])+ renderParametric "or"+ [ recRenderer t1 $ fullAnnSet [ta1] [fa1] []+ , recRenderer t2 $ fullAnnSet [ta2] [fa2] []+ ] TLambda (Ty t1 ta1) (Ty t2 ta2) ->- addParens pn $- "lambda" <+> annDoc <+>- renderBranches (- (recRenderer t1 $ singleAnnSet ta1) :|- [ recRenderer t2 $ singleAnnSet ta2- ])+ renderParametric "lambda"+ [ recRenderer t1 $ singleAnnSet ta1+ , recRenderer t2 $ singleAnnSet ta2+ ] TMap (Ty t1 ta1) (Ty t2 ta2) ->- addParens pn $- "map" <+> annDoc <+>- renderBranches (- (recRenderer t1 $ singleAnnSet ta1) :|- [ recRenderer t2 $ singleAnnSet ta2- ])+ renderParametric "map"+ [ recRenderer t1 $ singleAnnSet ta1+ , recRenderer t2 $ singleAnnSet ta2+ ] TBigMap (Ty t1 ta1) (Ty t2 ta2) ->- addParens pn $- "big_map" <+> annDoc <+>- renderBranches (- (recRenderer t1 $ singleAnnSet ta1) :|- [ recRenderer t2 $ singleAnnSet ta2- ])+ renderParametric "big_map"+ [ recRenderer t1 $ singleAnnSet ta1+ , recRenderer t2 $ singleAnnSet ta2+ ] instance Buildable Ty where build = buildRenderDoc@@ -262,7 +243,6 @@ | TChestKey | TSaplingState Natural | TSaplingTransaction Natural- | TTxRollupL2Address | TNever deriving stock (Eq, Show, Data, Generic, Lift)
src/Morley/Michelson/Untyped/Value.hs view
@@ -86,9 +86,6 @@ ValueUnit -> "Unit" ValueTrue -> "True" ValueFalse -> "False"- p@(ValuePair _ (ValuePair _ _)) ->- let encodedValues = linearizeRightCombValuePair p- in renderValuesList (renderDoc doesntNeedParens) encodedValues ValuePair l r -> renderPair pn (flip renderDoc l) (flip renderDoc r) ValueLeft l -> renderLeft pn $ flip renderDoc l ValueRight r -> renderRight pn $ flip renderDoc r@@ -126,6 +123,9 @@ linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op) linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r linearizeRightCombValuePair v = v :| []+{-# DEPRECATED linearizeRightCombValuePair+ "This transformation is not necessarily valid. \+ \The correct way to go about this is typecheck then print optimized representation." #-} renderElt :: RenderDoc op => Elt op -> Doc renderElt (Elt k v) = renderElt' (flip renderDoc k) (flip renderDoc v)
src/Morley/Michelson/Untyped/View.hs view
@@ -3,7 +3,7 @@ -- | Michelson view. module Morley.Michelson.Untyped.View- ( ViewName (.., ViewName)+ ( ViewName (ViewName, ..) , mkViewName , BadViewNameError (..) , isValidViewNameChar@@ -12,79 +12,28 @@ , viewNameToMText , View' (..)+ , ViewsSet (..)+ , mkViewsSet+ , VS.ViewsSetError (..)++ -- * Manipulation+ , emptyViewsSet+ , addViewToSet+ , lookupView+ , viewsSetNames ) where -import Control.Monad.Except (throwError)+import Data.Aeson (FromJSON, ToJSON) import Data.Aeson.TH (deriveJSON)+import Data.Coerce (coerce) import Data.Data (Data)-import Data.Text qualified as Text-import Fmt (Buildable(..), (+|), (|+))-import Text.PrettyPrint.Leijen.Text (Doc, dquotes, textStrict)+import Data.Default (Default) -import Morley.Michelson.Printer.Util-import Morley.Michelson.Text+import Morley.Michelson.Internal.ViewName+import Morley.Michelson.Internal.ViewsSet qualified as VS import Morley.Michelson.Untyped.Type import Morley.Util.Aeson --- | Name of the view.------ 1. It must not exceed 31 chars length;--- 2. Must use [a-zA-Z0-9_.%@] charset.-newtype ViewName = UnsafeViewName { unViewName :: Text }- deriving stock (Show, Eq, Ord, Data, Generic)- deriving newtype (Buildable, NFData)--pattern ViewName :: Text -> ViewName-pattern ViewName name <- UnsafeViewName name-{-# COMPLETE ViewName #-}---- | Whether the given character is valid for a view.-isValidViewNameChar :: Char -> Bool-isValidViewNameChar c = or- [ 'A' <= c && c <= 'Z'- , 'a' <= c && c <= 'z'- , '0' <= c && c <= '9'- , c `elem` ['_', '.', '%', '@']- ]---- | Maximum allowed name length for a view.-viewNameMaxLength :: Int-viewNameMaxLength = 31--data BadViewNameError- = BadViewTooLong Int- | BadViewIllegalChars Text- deriving stock (Show, Eq, Ord, Data, Generic)- deriving anyclass (NFData)--instance Buildable BadViewNameError where- build = \case- BadViewTooLong l ->- "Bad view name length of " +| l |+ " characters, must not exceed \- \" +| viewNameMaxLength |+ " characters length"- BadViewIllegalChars txt ->- "Invalid characters in the view \"" +| txt |+ ", allowed characters set \- \is [a-zA-Z0-9_.%@]"---- | Construct t'ViewName' performing all the checks.-mkViewName :: Text -> Either BadViewNameError ViewName-mkViewName txt = do- unless (length txt <= viewNameMaxLength) $- throwError (BadViewTooLong $ length txt)- unless (Text.all isValidViewNameChar txt) $- throwError (BadViewIllegalChars txt)- return (UnsafeViewName txt)--renderViewName :: ViewName -> Doc-renderViewName = dquotes . textStrict . unViewName--instance RenderDoc ViewName where- renderDoc _ = renderViewName---- | Valid view names form a subset of valid Michelson texts.-viewNameToMText :: ViewName -> MText-viewNameToMText = unsafe . mkMText . unViewName- -- | Untyped view in a contract. data View' op = View { viewName :: ViewName@@ -99,5 +48,23 @@ instance NFData op => NFData (View' op) -deriveJSON morleyAesonOptions ''ViewName deriveJSON morleyAesonOptions ''View'++newtype ViewsSet instr = UnsafeViewsSet { unViewsSet :: Map ViewName (View' instr) }+ deriving newtype (FromJSON, ToJSON, Default, NFData, Container)+ deriving stock (Eq, Show, Data, Functor)++mkViewsSet :: [View' instr] -> Either VS.ViewsSetError (ViewsSet instr)+mkViewsSet = coerce ... VS.mkViewsSet viewName++emptyViewsSet :: forall instr. ViewsSet instr+emptyViewsSet = coerce $ VS.emptyViewsSet @(View' instr)++addViewToSet :: View' instr -> ViewsSet instr -> Either VS.ViewsSetError (ViewsSet instr)+addViewToSet x = coerce $ VS.addViewToSet viewName x++lookupView :: forall instr. ViewName -> ViewsSet instr -> Maybe (View' instr)+lookupView = coerce . VS.lookupView @(View' instr)++viewsSetNames :: forall instr. ViewsSet instr -> Set ViewName+viewsSetNames = VS.viewsSetNames @(View' instr) . coerce
src/Morley/Tezos/Address.hs view
@@ -8,25 +8,22 @@ module Morley.Tezos.Address ( ContractHash , KindedAddress (..)- , TxRollupL2Address (..) , mkKeyAddress , detGenKeyAddress , isImplicitAddress , ImplicitAddress , ContractAddress- , TxRollupAddress+ , SmartRollupAddress , L1Address , L1AddressKind , ConstrainAddressKind , Address , ConstrainedAddress- , AnyParsableAddress(..)- , Constrained(.., MkConstrainedAddress, MkAddress)+ , Constrained(.., MkAddress) , GlobalCounter(..) , mkContractHashHack , parseConstrainedAddress- , parseAnyAddress -- * Formatting , ParseAddressError (..)@@ -42,6 +39,7 @@ , addressKindSanity , usingImplicitOrContractKind , unImplicitAddress+ , addressKindTag ) where import Control.Monad.Except (mapExceptT, throwError)@@ -52,6 +50,7 @@ import Data.Binary.Get qualified as Get import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS+import Data.Char (toUpper) import Data.Constraint (Bottom(..), Dict(..), (\\)) import Data.Constraint.Extras (has) import Data.Constraint.Extras.TH (deriveArgDict)@@ -66,6 +65,7 @@ import Language.Haskell.TH.Quote qualified as TH import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax qualified as TH+import Options.Applicative (ReadM) import Text.PrettyPrint.Leijen.Text (backslash, dquotes, int, (<+>)) import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderAnyBuildable)@@ -88,8 +88,7 @@ ImplicitAddress :: KeyHash -> KindedAddress 'AddressKindImplicit -- | @KT1@ address which corresponds to a callable contract. ContractAddress :: ContractHash -> KindedAddress 'AddressKindContract- -- | @txr1@ address which corresponds to a transaction rollup.- TxRollupAddress :: TxRollupHash -> KindedAddress 'AddressKindTxRollup+ SmartRollupAddress :: SmartRollupHash -> KindedAddress 'AddressKindSmartRollup deriving stock instance Show (KindedAddress kind) deriving stock instance Eq (KindedAddress kind)@@ -107,8 +106,8 @@ -- | A type only allowing v'ContractAddress' type ContractAddress = KindedAddress 'AddressKindContract --- | A type only allowing v'TxRollupAddress'-type TxRollupAddress = KindedAddress 'AddressKindTxRollup+-- | A type only allowing v'SmartRollupAddress'+type SmartRollupAddress = KindedAddress 'AddressKindSmartRollup -- | Data type corresponding to @address@ structure in Tezos. type Address = Constrained NullConstraint KindedAddress@@ -139,23 +138,15 @@ type ConstrainedAddress (ks :: [AddressKind]) = Constrained (ConstrainAddressKind ks) KindedAddress -pattern MkConstrainedAddress- :: forall ks. ()- => forall kind. ConstrainAddressKind ks kind- => KindedAddress kind -> ConstrainedAddress ks-pattern MkConstrainedAddress a = Constrained a-{-# COMPLETE MkConstrainedAddress #-}-{-# DEPRECATED MkConstrainedAddress "Use Constrained instead" #-}- -- | A convenience synonym for 'ConstrainedAddress' allowing only implicit and -- contract addresses. -- -- 'L1Address' is named as such because in addition to implicit and contract--- addresses, Michelson's @address@ type can contain @txr1@ addresses,--- identifying transaction rollups. While @txr1@ are technically also level-1--- (level-2 being @tx_rollup_l2_address@, i.e. @tz4@), in practice it's a--- level-1 identifier for a bundle of level-2 operations. Hence, to keep type--- names concise, we use 'L1Address'.+-- addresses, Michelson's @address@ type can contain @txr1@ or @sr1@ addresses,+-- identifying respectively transaction rollups and smart rollups. While they+-- are technically also level-1 (level-2 being @tx_rollup_l2_address@), in+-- practice It's level-1 identifiers for bundles of level-2 operations. Hence,+-- to keep type names concise, we use 'L1Address'. type L1Address = ConstrainedAddress '[ 'AddressKindImplicit, 'AddressKindContract ] @@ -163,8 +154,7 @@ -- contract addresses. -- -- For a note on the naming convention, refer to 'L1Address'.-type L1AddressKind kind =- ConstrainAddressKind '[ 'AddressKindImplicit, 'AddressKindContract ] kind+type L1AddressKind = ConstrainAddressKind '[ 'AddressKindImplicit, 'AddressKindContract ] -- | A trick to avoid bogus redundant constraint warnings usingImplicitOrContractKind :: forall kind a. L1AddressKind kind => a -> a@@ -176,20 +166,6 @@ addressKindSanity :: KindedAddress kind -> Dict (SingI kind) addressKindSanity a = has @SingI a Dict --- | @tz4@ level-2 public key hash address, used with transaction rollups, corresponds--- to @tx_rollup_l2_address@ Michelson type.-newtype TxRollupL2Address = TxRollupL2Address KeyHashL2- deriving stock (Show, Eq, Ord, Generic, Lift)- deriving newtype NFData---- | A sum type for any known parsable address (@tz1@ - @tz4@, @KT1@, @txr1@)-data AnyParsableAddress- = AnyParsableL2Address TxRollupL2Address- | AnyParsableAddress Address- deriving stock (Show, Eq, Generic)--instance NFData AnyParsableAddress- -- | Checks if the provided 'KindedAddress' is an implicit address and returns -- proof of the fact if it is. isImplicitAddress :: KindedAddress kind -> Maybe (kind :~: 'AddressKindImplicit)@@ -245,7 +221,7 @@ \case ImplicitAddress h -> formatHash h ContractAddress h -> formatHash h- TxRollupAddress h -> formatHash h+ SmartRollupAddress h -> formatHash h mformatAddress :: KindedAddress kind -> MText mformatAddress = unsafe . mkMText . formatAddress@@ -253,14 +229,11 @@ instance Buildable (KindedAddress kind) where build = build . formatAddress -instance Buildable TxRollupL2Address where- build (TxRollupL2Address kh) = build $ formatHash kh- -- | Errors that can happen during address parsing. data ParseAddressError = ParseAddressCryptoError CryptoParseError -- ^ The address parsers failed with some error.- | ParseAddressWrongKind [AddressKind] AnyParsableAddress+ | ParseAddressWrongKind [AddressKind] Address -- ^ The parsed address is of wrong kind deriving stock (Show, Eq, Generic) @@ -273,14 +246,10 @@ renderDoc context = \case ParseAddressCryptoError pkErr -> "Address failed to parse: " <> renderDoc context pkErr- ParseAddressWrongKind expected (AnyParsableAddress (Constrained a)) -> mconcat+ ParseAddressWrongKind expected (Constrained a) -> mconcat [ "Expected address of kind ", renderAddressKinds expected , ", but got ", renderAnyBuildable a ]- ParseAddressWrongKind expected (AnyParsableL2Address a) -> mconcat- [ "Expected address of kind ", renderAddressKinds expected- , ", but got unexpected TxRollupL2Address ", renderAnyBuildable a- ] where renderAddressKinds as = mconcat $ intersperse ", " (renderAnyBuildable <$> as) @@ -293,7 +262,7 @@ parseKindedAddress addressText = do Constrained a <- parseConstrainedAddress @'[kind] addressText castSing a \\ addressKindSanity a &- maybeToRight (ParseAddressWrongKind [demote @kind] . AnyParsableAddress $ Constrained a)+ maybeToRight (ParseAddressWrongKind [demote @kind] $ Constrained a) -- | Parse an 'ConstrainedAddress' of the given kinds from its human-readable textual -- representation. Maybe fail with a 'ParseAddressWrongKind' in case the address parsed@@ -310,7 +279,7 @@ -> Address -> Either ParseAddressError (ConstrainedAddress kinds) castConstrainedAddress allowed = \case- SNil -> Left . ParseAddressWrongKind allowed . AnyParsableAddress+ SNil -> Left . ParseAddressWrongKind allowed SCons kind ks -> \case Constrained (a :: KindedAddress kind') | Just Refl <- testEquality kind (sing @kind') \\ addressKindSanity a@@ -323,46 +292,26 @@ Constrained x \\ proofAddressCast @xs (sing @k) sx \\ addressKindSanity x proofAddressCast- :: ConstrainAddressKind ks k+ :: forall ks k x. ConstrainAddressKind ks k => Sing k -> Sing x -> Dict (ConstrainAddressKind (x ': ks) k)-proofAddressCast k x = case x of- SAddressKindImplicit -> case k of- SAddressKindImplicit -> Dict- SAddressKindContract -> Dict- SAddressKindTxRollup -> Dict- SAddressKindContract -> case k of- SAddressKindImplicit -> Dict- SAddressKindContract -> Dict- SAddressKindTxRollup -> Dict- SAddressKindTxRollup -> case k of- SAddressKindImplicit -> Dict- SAddressKindContract -> Dict- SAddressKindTxRollup -> Dict+proofAddressCast = $(forEachAddressKind $ forEachAddressKind [|Dict|]) -- | Parse an address of arbitrary kind from its human-readable textual -- representation, or fail if it's invalid. parseAddress :: Text -> Either ParseAddressError Address-parseAddress x = parseAnyAddress x >>= \case- a@AnyParsableL2Address{} -> Left $ ParseAddressWrongKind [minBound..] a- AnyParsableAddress a -> Right a---- | Parse any kind of known address from it's human-readable textual--- representation, or fail if it's invalid.-parseAnyAddress :: Text -> Either ParseAddressError AnyParsableAddress-parseAnyAddress a = first ParseAddressCryptoError $ parseSomeHashBase58 a <&> \case- Some h@(Hash HashBLS _) -> AnyParsableL2Address $ TxRollupL2Address h- Some h@(Hash hk _) -> AnyParsableAddress $ case hk of- HashKey KeyTypeEd25519 -> Constrained $ ImplicitAddress h- HashKey KeyTypeSecp256k1 -> Constrained $ ImplicitAddress h- HashKey KeyTypeP256 -> Constrained $ ImplicitAddress h+parseAddress a = first ParseAddressCryptoError $ parseSomeHashBase58 a <&> \case+ Some h@(Hash hk _) -> case hk of+ HashKey{} -> Constrained $ ImplicitAddress h HashContract -> Constrained $ ContractAddress h- HashTXR -> Constrained $ TxRollupAddress h+ HashSR -> Constrained $ SmartRollupAddress h data ParseAddressRawError = ParseAddressRawWrongSize ByteString -- ^ Raw bytes representation of an address has invalid length. | ParseAddressRawInvalidPrefix Word8 -- ^ Raw bytes representation of an address has incorrect prefix.+ | ParseAddressRawUnsupportedPrefix Text Word8+ -- ^ Unsupported address type. | ParseAddressRawMalformedSeparator Word8 -- ^ Raw bytes representation of an address does not end with "\00". | ParseAddressRawBinaryError Text@@ -378,6 +327,9 @@ \case ParseAddressRawInvalidPrefix prefix -> "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"+ ParseAddressRawUnsupportedPrefix name prefix ->+ "Unsupported raw address prefix type" <+> renderAnyBuildable name+ <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "found" ParseAddressRawWrongSize addr -> "Given raw address+" <+> (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr) ParseAddressRawMalformedSeparator addr -> "Given raw address" <+> (renderAnyBuildable $ hexF addr) <+>@@ -401,12 +353,14 @@ | otherwise = either (Left . ParseAddressRawBinaryError . fromString . view _3) (view _3) $ flip Get.runGetOrFail (LBS.fromStrict bytes) $ runExceptT- $ decodeWithTagM "address" (throwError . ParseAddressRawInvalidPrefix)- [ 0x00 ##: MkAddress . ImplicitAddress <$> keyHash- , 0x01 ##: MkAddress . ContractAddress <$> sepHash HashContract- , 0x02 ##: MkAddress . TxRollupAddress <$> sepHash HashTXR- ]+ $ decodeWithTagM "address" (throwError . ParseAddressRawInvalidPrefix) decoders where+ decoders = txr1error : map mkDecoder [minBound..]+ txr1error = 0x02 ##: throwError (ParseAddressRawUnsupportedPrefix "txr1" 0x02)+ mkDecoder ak = addressKindTag ak ##: case ak of+ AddressKindImplicit -> MkAddress . ImplicitAddress <$> keyHash+ AddressKindContract -> MkAddress . ContractAddress <$> sepHash HashContract+ AddressKindSmartRollup -> MkAddress . SmartRollupAddress <$> sepHash HashSR sep = lift Get.getWord8 >>= \case 0x00 -> pass x -> throwError $ ParseAddressRawMalformedSeparator x@@ -414,6 +368,13 @@ sepHash :: HashTag kind -> ExceptT ParseAddressRawError Get.Get (Hash kind) sepHash kind = Hash kind <$> lift (getByteStringCopy hashLengthBytes) <* sep +addressKindTag :: AddressKind -> Word8+addressKindTag = \case+ AddressKindImplicit -> 0x00+ AddressKindContract -> 0x01+ -- 0x02 is txr1 which we do not support+ AddressKindSmartRollup -> 0x03+ -- | QuasiQuoter for constructing Tezos addresses. -- -- Validity of result will be checked at compile time.@@ -446,12 +407,20 @@ ---------------------------------------------------------------------------- instance SingI kind => HasCLReader (KindedAddress kind) where- getReader = eitherReader parseAddrDo- where- parseAddrDo addr =- first (mappend "Failed to parse address: " . pretty) $- parseKindedAddress $ toText addr+ getMetavar = toUpper <$> pretty (demote @kind) <> " ADDRESS"+ getReader = getAddressReader parseKindedAddress++instance SingI ks => HasCLReader (ConstrainedAddress ks) where+ getMetavar = intercalate " OR " (fmap toUpper . pretty <$> demote @ks) <> " ADDRESS"+ getReader = getAddressReader parseConstrainedAddress++instance HasCLReader Address where getMetavar = "ADDRESS"+ getReader = getAddressReader parseAddress++getAddressReader :: (Text -> Either ParseAddressError addr) -> ReadM addr+getAddressReader parser = eitherReader $+ first (mappend "Failed to parse address: " . pretty) . parser . toText ---------------------------------------------------------------------------- -- Aeson instances
src/Morley/Tezos/Address/Alias.hs view
@@ -97,22 +97,25 @@ class (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind instance (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind -{- | This type is meant to be used to parse CLI options where either an address or an alias-of an implicit account or a contract can be accepted.+{- | This type is meant to be used to parse CLI options where either an address+or an alias of an implicit account or a contract can be accepted. This can be later converted to an address using @Morley.Client.resolveAddress@ or an alias using @Morley.Client.getAlias@. -This polymorphic type can be instantiated with 'AddressKindImplicit' or 'AddressKindContract'-(see 'ImplicitAddressOrAlias' and 'ContractAddressOrAlias'),-but not 'AddressKindTxRollup'.-There is no @octez-client@ command to list tx rollup aliases,-unlike @octez-client list known addresses/contracts@, therefore:+This polymorphic type can be instantiated with 'AddressKindImplicit' or+'AddressKindContract' (see 'ImplicitAddressOrAlias' and+'ContractAddressOrAlias'), but not 'AddressKindSmartRollup'. There is no+@octez-client@ command to list smart rollup aliases, unlike @octez-client list+known addresses/contracts@, therefore: -1. It wouldn't be possible to implement @Morley.Client.resolveAddress@ for @AddressAlias _ :: AddressOrAlias 'AddressKindTxRollup@.-2. It wouldn't be possible to implement @Morley.Client.getAlias@ for @AddressResolved _ :: AddressOrAlias 'AddressKindTxRollup@.+1. It wouldn't be possible to implement @Morley.Client.resolveAddress@ for+ @AddressAlias _ :: AddressOrAlias 'AddressKindTxRollup@.+2. It wouldn't be possible to implement @Morley.Client.getAlias@ for+ @AddressResolved _ :: AddressOrAlias 'AddressKindTxRollup@. -This should be revisited if/when @octez-client@ adds support for tx rollup aliases.+This should be revisited if/when @octez-client@ adds support for smart rollup+aliases. -} data AddressOrAlias kind where AddressResolved :: L1AddressKind kind => KindedAddress kind -> AddressOrAlias kind@@ -222,7 +225,7 @@ case addr of ImplicitAddress{} -> pure $ SAOAKindSpecified $ AddressResolved addr ContractAddress{} -> pure $ SAOAKindSpecified $ AddressResolved addr- TxRollupAddress{} -> Opt.readerError $ "Unexpected transaction rollup address: " <> pretty addr+ SmartRollupAddress{} -> Opt.readerError $ "Unexpected smart rollup address: " <> pretty addr Left _ -> pure $ parseAliasWithPrefix @'AddressKindImplicit str <|> parseAliasWithPrefix @'AddressKindContract str
src/Morley/Tezos/Address/Kinds.hs view
@@ -9,9 +9,11 @@ module Morley.Tezos.Address.Kinds ( AddressKind(..) , SingAddressKind(..)+ , forEachAddressKind ) where import Fmt (Buildable(..))+import Language.Haskell.TH (ExpQ) import Morley.Util.Sing @@ -21,8 +23,8 @@ -- ^ an implicit address, @tz1@-@tz3@ | AddressKindContract -- ^ a contract address, @KT1@- | AddressKindTxRollup- -- ^ a transaction rollup address, @txr1@+ | AddressKindSmartRollup+ -- ^ a smart rollup address, @sr1@ deriving stock (Eq, Bounded, Enum, Ord, Show, Generic) instance NFData AddressKind@@ -31,6 +33,14 @@ build = \case AddressKindImplicit -> "implicit" AddressKindContract -> "contract"- AddressKindTxRollup -> "transaction rollup"+ AddressKindSmartRollup -> "smart rollup" genSingletonsType ''AddressKind++forEachAddressKind :: ExpQ -> ExpQ+forEachAddressKind r = [e|+ \case+ SAddressKindImplicit -> $r+ SAddressKindContract -> $r+ SAddressKindSmartRollup -> $r+ |]
src/Morley/Tezos/Crypto.hs view
@@ -26,6 +26,8 @@ -- (using @KT1@ prefix) and transaction rollups (using @txr1@ prefix) -- these -- hashes are also implemented here. --+-- We do not support @txr1@ addresses as those are disabled on the mainnet.+-- -- This module serves two purposes: -- 1. It is an umbrella module that re-exports some stuff from other modules. -- 2. Michelson types such as @key@ and @signature@ may store primitive of any@@ -48,9 +50,8 @@ , Hash (..) , HashKind (..) , KeyHash- , KeyHashL2 , ContractHash- , TxRollupHash+ , SmartRollupHash , BLS12381.Bls12381Fr , BLS12381.Bls12381G1 , BLS12381.Bls12381G2@@ -59,7 +60,10 @@ , detSecretKey , detSecretKey' , KeyType(..)+ , keyTypeTag+ , publicKeyType , toPublic+ , publicKeyToBytes -- * Signature , signatureToBytes@@ -82,7 +86,6 @@ , mformatHash , parseHash , parseKeyHashRaw- , parseKeyHashL2Raw , hashLengthBytes , formatSecretKey , parseSecretKey@@ -136,6 +139,7 @@ import Language.Haskell.TH.Syntax (Lift) import Morley.Michelson.Text+import Morley.Tezos.Crypto.BLS qualified as BLS import Morley.Tezos.Crypto.BLS12381 qualified as BLS12381 import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 import Morley.Tezos.Crypto.Hash@@ -155,24 +159,30 @@ -- | A kind of a hash. data HashKind = HashKindPublicKey -- ^ Public key hash for @tz1@, @tz2@, @tz3@ addresses.- | HashKindL2PublicKey -- ^ Level-2 public key hash for @tz4@ addresses. | HashKindContract -- ^ Contract hash for @KT1@ smart contract addresses.- | HashKindTxRollup -- ^ Transaction rollup hash for @txr1@ addresses.+ | HashKindSmartRollup -- ^ Smart rollup hash for @sr1@ addresses. -- | Type of public/secret key as enum. data KeyType = KeyTypeEd25519 | KeyTypeSecp256k1 | KeyTypeP256+ | KeyTypeBLS deriving stock (Show, Eq, Enum, Bounded, Ord, Lift, Generic) deriving anyclass NFData +instance Buildable KeyType where+ build = \case+ KeyTypeEd25519 -> "key Ed25519"+ KeyTypeSecp256k1 -> "key Secp256k1"+ KeyTypeP256 -> "key P256"+ KeyTypeBLS -> "key BLS"+ -- | What specific type of hash is used for the 'Hash'. data HashTag (kind :: HashKind) where HashKey :: KeyType -> HashTag 'HashKindPublicKey HashContract :: HashTag 'HashKindContract- HashBLS :: HashTag 'HashKindL2PublicKey- HashTXR :: HashTag 'HashKindTxRollup+ HashSR :: HashTag 'HashKindSmartRollup deriving stock instance Show (HashTag kind) deriving stock instance Eq (HashTag kind)@@ -192,6 +202,8 @@ -- ^ Public key that uses the secp256k1 cryptographic curve. | PublicKeyP256 P256.PublicKey -- ^ Public key that uses the NIST P-256 cryptographic curve.+ | PublicKeyBLS BLS.PublicKey+ -- ^ Public key that uses the BLS12-381 cryptographic curve. deriving stock (Show, Eq, Ord, Generic) instance NFData PublicKey@@ -205,6 +217,8 @@ -- ^ Secret key that uses the secp256k1 cryptographic curve. | SecretKeyP256 P256.SecretKey -- ^ Secret key that uses the NIST P-256 cryptographic curve.+ | SecretKeyBLS BLS.SecretKey+ -- ^ Secret key that uses BLS12-381 curve. deriving stock (Show, Eq, Generic) instance NFData SecretKey@@ -220,6 +234,7 @@ KeyTypeEd25519 -> SecretKeyEd25519 . Ed25519.detSecretKey KeyTypeSecp256k1 -> SecretKeySecp256k1 . Secp256k1.detSecretKey KeyTypeP256 -> SecretKeyP256 . P256.detSecretKey+ KeyTypeBLS -> SecretKeyBLS . BLS.detSecretKey -- | Deterministically generate a secret key from seed. Type of the key depends -- on seed value.@@ -234,6 +249,7 @@ SecretKeyEd25519 sk -> PublicKeyEd25519 . Ed25519.toPublic $ sk SecretKeySecp256k1 sk -> PublicKeySecp256k1 . Secp256k1.toPublic $ sk SecretKeyP256 sk -> PublicKeyP256 . P256.toPublic $ sk+ SecretKeyBLS sk -> PublicKeyBLS . BLS.toPublic $ sk -- | Cryptographic signatures used by Tezos. -- Constructors correspond to 'PublicKey' constructors.@@ -253,6 +269,8 @@ -- ^ Siganture that uses the secp256k1 cryptographic curve. | SignatureP256 P256.Signature -- ^ Signature that uses the NIST P-256 cryptographic curve.+ | SignatureBLS BLS.Signature+ -- ^ Signature that uses the BLS12-381 cryptographic curve. | SignatureGeneric ByteString -- ^ Generic signature for which curve is unknown. deriving stock (Show, Generic)@@ -266,15 +284,8 @@ -- a different (with respect to 'Eq') signature which is inconvenient. instance Eq Signature where sig1 == sig2 = case (sig1, sig2) of- (SignatureGeneric bytes1, SignatureGeneric bytes2) -> bytes1 == bytes2- (SignatureGeneric bytes1, SignatureEd25519 (Ed25519.signatureToBytes -> bytes2)) ->- bytes1 == bytes2- (SignatureGeneric bytes1, SignatureSecp256k1 (Secp256k1.signatureToBytes -> bytes2)) ->- bytes1 == bytes2- (SignatureGeneric bytes1, SignatureP256 (P256.signatureToBytes -> bytes2)) ->- bytes1 == bytes2-- (_, SignatureGeneric {}) -> sig2 == sig1+ (SignatureGeneric bytes1, _) -> bytes1 == signatureToBytes sig2+ (_, SignatureGeneric bytes2) -> signatureToBytes sig1 == bytes2 (SignatureEd25519 s1, SignatureEd25519 s2) -> s1 == s2 (SignatureEd25519 {}, _) -> False@@ -285,8 +296,11 @@ (SignatureP256 s1, SignatureP256 s2) -> s1 == s2 (SignatureP256 {}, _) -> False + (SignatureBLS s1, SignatureBLS s2) -> s1 == s2+ (SignatureBLS {}, _) -> False+ instance Ord Signature where- compare = compare `on` (signatureToBytes :: Signature -> ByteString)+ compare = compare `on` signatureToBytes @ByteString ---------------------------------------------------------------------------- -- Signature@@ -298,15 +312,18 @@ SignatureEd25519 sig -> Ed25519.signatureToBytes sig SignatureSecp256k1 sig -> Secp256k1.signatureToBytes sig SignatureP256 sig -> P256.signatureToBytes sig+ SignatureBLS sig -> BLS.signatureToBytes sig SignatureGeneric bytes -> BA.convert bytes -- | Make a 'Signature' from raw bytes.--- Can return only generic signature.+-- Can return only 'SignatureGeneric' or 'SignatureBLS' mkSignature :: BA.ByteArray ba => ba -> Maybe Signature-mkSignature ba =- SignatureGeneric (BA.convert ba) <$ guard (l == signatureLengthBytes)+mkSignature ba+ | l == signatureLengthBytes = Just $ SignatureGeneric $ BA.convert ba+ | l == BLS.signatureLengthBytes = SignatureBLS <$> rightToMaybe (BLS.mkSignature ba)+ | otherwise = Nothing where- l = BA.length ba+ l = BA.length ba parseSignatureRaw :: ByteString -> Either ParseSignatureRawError Signature parseSignatureRaw ba = maybeToRight (ParseSignatureRawWrongSize ba) $ mkSignature ba@@ -333,7 +350,8 @@ [ Ed25519.signatureLengthBytes , P256.signatureLengthBytes , Secp256k1.signatureLengthBytes- ] = 64+ ]+ = 64 | otherwise = error "Apparently our understanding of signatures in Tezos is broken" where@@ -353,6 +371,8 @@ Secp256k1.checkSignature pk sig bytes (PublicKeyP256 pk, SignatureP256 sig) -> P256.checkSignature pk sig bytes+ (PublicKeyBLS pk, SignatureBLS sig) ->+ BLS.checkSignature pk sig bytes (PublicKeyEd25519 pk, SignatureGeneric sBytes) -> case Ed25519.mkSignature sBytes of Right sig -> Ed25519.checkSignature pk sig bytes@@ -373,6 +393,7 @@ SecretKeyEd25519 sk' -> pure $ SignatureEd25519 $ Ed25519.sign sk' bs SecretKeySecp256k1 sk' -> SignatureSecp256k1 <$> Secp256k1.sign sk' bs SecretKeyP256 sk' -> SignatureP256 <$> P256.sign sk' bs+ SecretKeyBLS sk' -> pure $ SignatureBLS $ BLS.sign sk' bs ---------------------------------------------------------------------------- -- Formatting@@ -383,6 +404,7 @@ PublicKeyEd25519 pk -> Ed25519.formatPublicKey pk PublicKeySecp256k1 pk -> Secp256k1.formatPublicKey pk PublicKeyP256 pk -> P256.formatPublicKey pk+ PublicKeyBLS pk -> BLS.formatPublicKey pk mformatPublicKey :: PublicKey -> MText mformatPublicKey = unsafe . mkMText . formatPublicKey@@ -396,6 +418,7 @@ ( fmap PublicKeyEd25519 . Ed25519.parsePublicKey :| [ fmap PublicKeySecp256k1 . Secp256k1.parsePublicKey , fmap PublicKeyP256 . P256.parsePublicKey+ , fmap PublicKeyBLS . BLS.parsePublicKey ]) parsePublicKeyRaw :: ByteString -> Either Text PublicKey@@ -407,6 +430,7 @@ SignatureEd25519 sig -> Ed25519.formatSignature sig SignatureSecp256k1 sig -> Secp256k1.formatSignature sig SignatureP256 sig -> P256.formatSignature sig+ SignatureBLS sig -> BLS.formatSignature sig SignatureGeneric sig -> formatImpl genericSignatureTag sig mformatSignature :: Signature -> MText@@ -421,6 +445,7 @@ ( fmap SignatureEd25519 . Ed25519.parseSignature :| [ fmap SignatureSecp256k1 . Secp256k1.parseSignature , fmap SignatureP256 . P256.parseSignature+ , fmap SignatureBLS . BLS.parseSignature , parseImpl genericSignatureTag (pure . SignatureGeneric) ]) @@ -429,6 +454,7 @@ SecretKeyEd25519 sig -> Ed25519.formatSecretKey sig SecretKeySecp256k1 sig -> Secp256k1.formatSecretKey sig SecretKeyP256 sig -> P256.formatSecretKey sig+ SecretKeyBLS sig -> BLS.formatSecretKey sig instance Buildable SecretKey where build = build . formatSecretKey@@ -441,6 +467,7 @@ ( fmap SecretKeyEd25519 . Ed25519.parseSecretKey :| [ fmap SecretKeySecp256k1 . Secp256k1.parseSecretKey , fmap SecretKeyP256 . P256.parseSecretKey+ , fmap SecretKeyBLS . BLS.parseSecretKey ]) where removePrefix :: Text -> Text@@ -511,11 +538,8 @@ instance AllHashTags 'HashKindContract where allHashTags = pure HashContract -instance AllHashTags 'HashKindL2PublicKey where- allHashTags = pure HashBLS--instance AllHashTags 'HashKindTxRollup where- allHashTags = pure HashTXR+instance AllHashTags 'HashKindSmartRollup where+ allHashTags = pure HashSR -- | Blake2b_160 hash of something. data Hash (kind :: HashKind) = Hash@@ -530,14 +554,11 @@ -- | Convenience synonym for an on-chain public key hash. type KeyHash = Hash 'HashKindPublicKey --- | Convenience synonym for a level-2 public key hash.-type KeyHashL2 = Hash 'HashKindL2PublicKey- -- | Convenience synonym for a contract hash. type ContractHash = Hash 'HashKindContract --- | Convenience synonym for a transaction rollup hash.-type TxRollupHash = Hash 'HashKindTxRollup+-- | Convenience synonym for a smart rollup hash.+type SmartRollupHash = Hash 'HashKindSmartRollup -- | Length of a hash in bytes (only the hash itself, no tags, checksums -- or anything).@@ -546,15 +567,22 @@ -- | Compute the b58check of a public key hash. hashKey :: PublicKey -> KeyHash-hashKey =- \case- PublicKeyEd25519 pk ->- Hash (HashKey KeyTypeEd25519) (blake2b160 $ Ed25519.publicKeyToBytes pk)- PublicKeySecp256k1 pk ->- Hash (HashKey KeyTypeSecp256k1) (blake2b160 $ Secp256k1.publicKeyToBytes pk)- PublicKeyP256 pk ->- Hash (HashKey KeyTypeP256) (blake2b160 $ P256.publicKeyToBytes pk)+hashKey pk = Hash (HashKey (publicKeyType pk)) $ blake2b160 $ publicKeyToBytes pk +publicKeyToBytes :: PublicKey -> ByteString+publicKeyToBytes = \case+ PublicKeyEd25519 pk -> Ed25519.publicKeyToBytes pk+ PublicKeySecp256k1 pk -> Secp256k1.publicKeyToBytes pk+ PublicKeyP256 pk -> P256.publicKeyToBytes pk+ PublicKeyBLS pk -> BLS.publicKeyToBytes pk++mkPublicKey :: BA.ByteArray ba => KeyType -> ba -> Either CryptoParseError PublicKey+mkPublicKey = \case+ KeyTypeEd25519 -> fmap PublicKeyEd25519 . Ed25519.mkPublicKey+ KeyTypeSecp256k1 -> fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey+ KeyTypeP256 -> fmap PublicKeyP256 . P256.mkPublicKey+ KeyTypeBLS -> fmap PublicKeyBLS . BLS.mkPublicKey+ formatHash :: (Hash kind) -> Text formatHash (Hash tag bytes) = formatImpl (hashTagBytes tag) bytes @@ -607,10 +635,6 @@ parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash parseKeyHashRaw = parseKeyHashHelper (hashLengthBytes + 1) "key_hash" decodeKeyHash -parseKeyHashL2Raw :: ByteString -> Either CryptoParseError KeyHashL2-parseKeyHashL2Raw = parseKeyHashHelper hashLengthBytes "tx_rollup_l2_address" $- lift $ Hash HashBLS <$> getByteStringCopy hashLengthBytes- -- | Magic constants used by Tezos to encode hashes with proper prefixes. hashTagBytes :: HashTag kind -> ByteString hashTagBytes =@@ -621,47 +645,61 @@ -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L381 HashKey KeyTypeP256 -> "\006\161\164" -- tz3 -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L383+ HashKey KeyTypeBLS -> "\006\161\166" -- tz4+ -- https://gitlab.com/tezos/tezos/-/blob/4b0dd9e9715ce82ac6429571d8843ab681522daf/src/lib_crypto/base58.ml#L371 HashContract -> "\2\90\121" -- KT1 -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_alpha/lib_protocol/contract_hash.ml#L27- HashBLS -> "\006\161\166" -- tz4- -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L43- HashTXR -> "\001\128\120\031" -- txr1- -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L35+ HashSR -> "\006\124\117" -- sr1+ -- https://gitlab.com/tezos/tezos/-/blob/f7f6047237974ef85d94c87368f2a82615bcc8ca/src/proto_016_PtMumbai/lib_protocol/sc_rollup_repr.ml#L33 parseSomeHashTag :: ByteString -> Either CryptoParseError (Some HashTag, ByteString)-parseSomeHashTag bs = maybeToRight (CryptoParseWrongTag bs) $ asum+parseSomeHashTag bs = maybeToRight failHash $ asum [ tryHash (HashKey KeyTypeEd25519) , tryHash (HashKey KeyTypeSecp256k1) , tryHash (HashKey KeyTypeP256)+ , tryHash (HashKey KeyTypeBLS) , tryHash HashContract- , tryHash HashBLS- , tryHash HashTXR+ , tryHash HashSR ] where tryHash :: HashTag kind -> Maybe (Some HashTag, ByteString) tryHash hashKind = (Some hashKind,) <$> BS.stripPrefix (hashTagBytes hashKind) bs + hashTXR = "\001\128\120\031" -- txr1+ -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L35++ failHash :: CryptoParseError+ failHash+ | hashTXR `BS.isPrefixOf` bs = CryptoParseUnsupportedTag "txr1" bs+ | otherwise = CryptoParseWrongTag bs+ instance AllHashTags kind => HasCLReader (Hash kind) where getReader = eitherReader (first pretty . parseHash . toText) getMetavar = "KEY_HASH" +keyTypeTag :: KeyType -> Word8+keyTypeTag = \case+ KeyTypeEd25519 -> 0x00+ KeyTypeSecp256k1 -> 0x01+ KeyTypeP256 -> 0x02+ KeyTypeBLS -> 0x03++publicKeyType :: PublicKey -> KeyType+publicKeyType = \case+ PublicKeyEd25519{} -> KeyTypeEd25519+ PublicKeySecp256k1{} -> KeyTypeSecp256k1+ PublicKeyP256{} -> KeyTypeP256+ PublicKeyBLS{} -> KeyTypeBLS+ keyDecoders :: [TaggedDecoder PublicKey]-keyDecoders =- [ 0x00 #: decodeBytesLike "key Ed25519"- (fmap PublicKeyEd25519 . Ed25519.mkPublicKey)- , 0x01 #: decodeBytesLike "key Secp256k1"- (fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)- , 0x02 #: decodeBytesLike "key P256"- (fmap PublicKeyP256 . P256.mkPublicKey)- ]+keyDecoders = [minBound..] <&> mkKeyParser+ where+ mkKeyParser x = keyTypeTag x #: decodeBytesLike (pretty x) (mkPublicKey x) keyHashDecoders :: (Monad (t Get.Get), MonadTrans t) => [TaggedDecoderM t KeyHash]-keyHashDecoders =- [ 0x00 ##: Hash (HashKey KeyTypeEd25519) <$> getPayload- , 0x01 ##: Hash (HashKey KeyTypeSecp256k1) <$> getPayload- , 0x02 ##: Hash (HashKey KeyTypeP256) <$> getPayload- ]+keyHashDecoders = [minBound..] <&> mkKeyHashParser where+ mkKeyHashParser kt = keyTypeTag kt ##: Hash (HashKey kt) <$> getPayload getPayload = lift $ getByteStringCopy hashLengthBytes decodeKeyHash :: ExceptT CryptoParseError Get.Get KeyHash
+ src/Morley/Tezos/Crypto/BLS.hs view
@@ -0,0 +1,202 @@+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | BLS-MinPk cryptographic primitives.++module Morley.Tezos.Crypto.BLS+ ( -- * Cryptographic primitive types+ PublicKey (..)+ , SecretKey+ , Signature (..)+ , detSecretKey+ , randomSecretKey+ , toPublic++ -- * Raw bytes (no checksums, tags or anything)+ , publicKeyToBytes+ , mkPublicKey+ , publicKeyLengthBytes+ , signatureToBytes+ , mkSignature+ , signatureLengthBytes++ -- * Formatting and parsing+ , formatPublicKey+ , mformatPublicKey+ , parsePublicKey+ , formatSecretKey+ , parseSecretKey+ , formatSignature+ , mformatSignature+ , parseSignature++ -- * Signing+ , sign+ , checkSignature+ ) where++import Crypto.BLST qualified as BLST+import Crypto.Random (MonadRandom(getRandomBytes))+import Data.ByteArray (ByteArray, ByteArrayAccess, Bytes, convert)+import Data.ByteArray.Sized (SizedByteArray(..), sizedByteArray)+import Fmt (Buildable, Builder, build)++import Morley.Michelson.Text+import Morley.Tezos.Crypto.Util++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++type MinPk = 'BLST.G1++-- | Domain separation tag used by tezos+dst :: Maybe ByteString+-- see https://gitlab.com/nomadic-labs/cryptography/ocaml-bls12-381-signature/-/blob/1.0.0/src/bls12_381_signature.ml#L350+-- https://gitlab.com/tezos/tezos/-/blob/e9a9b61969b7a44749bed9bd9cdbcb4f2283220f/src/lib_crypto/bls.ml#L333+dst = Just "BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_AUG_"++-- | BLS-MinPk public cryptographic key.+newtype PublicKey = PublicKey+ { unPublicKey :: BLST.PublicKey MinPk+ } deriving stock (Show, Eq, Generic)+ deriving anyclass NFData++instance Ord PublicKey where+ compare = compare `on` (publicKeyToBytes :: PublicKey -> ByteString)++-- | BLS-MinPk secret cryptographic key.+newtype SecretKey = SecretKey+ { unSecretKey :: BLST.SecretKey+ } deriving stock (Show, Eq, Generic)+ deriving anyclass NFData++-- | Deterministicaly generate a secret key from seed.+detSecretKey :: ByteString -> SecretKey+detSecretKey seed = SecretKey $ deterministic seed do+ bs <- fromMaybe (error "impossible") . sizedByteArray @32 @Bytes <$> getRandomBytes 32+ pure $ BLST.keygen bs++-- | Generate a random secret key.+randomSecretKey :: MonadRandom m => m SecretKey+randomSecretKey = detSecretKey <$> getRandomBytes 32++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic = PublicKey . BLST.skToPk . unSecretKey++-- | BLS-MinPk cryptographic signature.+newtype Signature = Signature+ { unSignature :: BLST.Signature MinPk 'BLST.Hash+ } deriving stock (Show, Eq, Generic)+ deriving anyclass NFData++----------------------------------------------------------------------------+-- Conversion to/from raw bytes (no checksums, tags or anything)+----------------------------------------------------------------------------++-- | Convert a 'PublicKey' to raw bytes.+publicKeyToBytes :: ByteArray ba => PublicKey -> ba+publicKeyToBytes = convert . unSizedByteArray . BLST.compressPk . unPublicKey++-- | Convert a 'PublicKey' to raw bytes.+secretKeyToBytes :: ByteArray ba => SecretKey -> ba+secretKeyToBytes = convert . unSizedByteArray . BLST.serializeSk . unSecretKey++toSized+ :: forall n a. (KnownNat n, ByteArrayAccess a)+ => Builder -> a -> Either CryptoParseError (SizedByteArray n a)+toSized what =+ maybeToRight (CryptoParseUnexpectedLength what $ fromIntegralOverflowing $ natVal @n Proxy)+ . sizedByteArray++-- | Make a 'PublicKey' from raw bytes.+mkPublicKey :: ByteArrayAccess ba => ba -> Either CryptoParseError PublicKey+mkPublicKey = toSized "public key" >=> bimap CryptoParseBLSTError PublicKey . BLST.decompressPk++publicKeyLengthBytes :: (Integral n, CheckIntSubType Int n) => n+publicKeyLengthBytes = fromIntegral $ BLST.byteSize @'BLST.Compress @(BLST.PublicKey MinPk)++-- | Convert a 'Signature' to raw bytes.+signatureToBytes :: ByteArray ba => Signature -> ba+signatureToBytes = convert . unSizedByteArray . BLST.compressSignature . unSignature++-- | Make a 'Signature' from raw bytes.+mkSignature :: ByteArrayAccess ba => ba -> Either CryptoParseError Signature+mkSignature = toSized "signature" >=>+ bimap CryptoParseBLSTError Signature . BLST.decompressSignature++signatureLengthBytes :: (Integral n, CheckIntSubType Int n) => n+signatureLengthBytes = fromIntegral $ BLST.byteSize @'BLST.Compress @(BLST.Signature MinPk 'BLST.Hash)++mkSecretKey :: ByteArrayAccess ba => ba -> Either CryptoParseError SecretKey+mkSecretKey = toSized "secret key" >=>+ bimap CryptoParseBLSTError SecretKey . pure . BLST.deserializeSk++----------------------------------------------------------------------------+-- Magic bytes+----------------------------------------------------------------------------++-- https://gitlab.com/tezos/tezos/-/blob/4b0dd9e9715ce82ac6429571d8843ab681522daf/src/lib_crypto/base58.ml#L428++publicKeyTag :: ByteString+publicKeyTag = "\006\149\135\204" -- BLpk(76)++secretKeyTag :: ByteString+secretKeyTag = "\003\150\192\040" -- BLsk(54)++signatureTag :: ByteString+signatureTag = "\040\171\064\207" -- BLsig(142)++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++formatPublicKey :: PublicKey -> Text+formatPublicKey = formatImpl publicKeyTag . publicKeyToBytes @Bytes++mformatPublicKey :: PublicKey -> MText+mformatPublicKey = unsafe . mkMText . formatPublicKey++instance Buildable PublicKey where+ build = build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey = parseImpl publicKeyTag mkPublicKey++formatSecretKey :: SecretKey -> Text+formatSecretKey = formatImpl secretKeyTag . secretKeyToBytes @Bytes++instance Buildable SecretKey where+ build = build . formatSecretKey++parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey = parseImpl secretKeyTag mkSecretKey++formatSignature :: Signature -> Text+formatSignature = formatImpl signatureTag . signatureToBytes @Bytes++mformatSignature :: Signature -> MText+mformatSignature = unsafe . mkMText . formatSignature++instance Buildable Signature where+ build = build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature = parseImpl signatureTag mkSignature++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++-- | Sign a message using the secret key.+sign :: SecretKey -> ByteString -> Signature+sign sk msg = Signature $ BLST.sign (unSecretKey sk)+ (publicKeyToBytes (toPublic sk) <> msg) dst+-- upstream does this concatenation with compressed public key+-- https://gitlab.com/nomadic-labs/cryptography/ocaml-bls12-381-signature/-/blob/531ed1f509a974f5067f431b6797b9246518520c/src/bls12_381_signature.ml#L662++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature pkg@(PublicKey pk) (Signature sig) bytes =+ BLST.BlstSuccess == BLST.verify sig pk (publicKeyToBytes pkg <> bytes) dst
src/Morley/Tezos/Crypto/Util.hs view
@@ -28,6 +28,7 @@ import Debug qualified (show) +import Crypto.BLST (BlstError) import Crypto.Error (CryptoError) import Crypto.Number.ModArithmetic (squareRoot) import Crypto.Number.Serialize (i2ospOf_, os2ip)@@ -53,7 +54,9 @@ data CryptoParseError = CryptoParseWrongBase58Check | CryptoParseWrongTag ByteString+ | CryptoParseUnsupportedTag Builder ByteString | CryptoParseCryptoError CryptoError+ | CryptoParseBLSTError BlstError | CryptoParseUnexpectedLength Builder Int | CryptoParseBinaryError Text deriving stock (Show, Eq)@@ -67,15 +70,16 @@ instance RenderDoc CryptoParseError where renderDoc _ = \case CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"- CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> (renderAnyBuildable $ hexF tag)+ CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> renderAnyBuildable (hexF tag)+ CryptoParseUnsupportedTag name tag ->+ "Unsupported hash" <+> renderAnyBuildable name <> ":" <+> renderAnyBuildable (hexF tag) CryptoParseCryptoError err ->- "Cryptographic library reported an error: " <>- (renderAnyBuildable $ (displayException err))+ "Cryptographic library reported an error:" <+> renderAnyBuildable (displayException err)+ CryptoParseBLSTError err ->+ "Cryptographic library reported an error:" <+> renderAnyBuildable (displayException err) CryptoParseUnexpectedLength what l -> "Unexpected length of" <+> renderAnyBuildable what <> ":" <+> int l CryptoParseBinaryError err -> textStrict err-- -- | Encode a bytestring in Base58Check format. encodeBase58Check :: ByteString -> Text
src/Morley/Util/CLI.hs view
@@ -29,7 +29,6 @@ ) where import Data.Bits (Bits)-import Data.Text.Manipulate (toSpinal) import Fmt (Buildable, pretty) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Options.Applicative@@ -38,6 +37,7 @@ import Morley.Util.Instances () import Morley.Util.Named+import Morley.Util.Text (toSpinal) -- | Maybe add the default value and make sure it will be shown in -- help message.
src/Morley/Util/Interpolate/Internal.hs view
@@ -1,13 +1,11 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Internal module exporting utilities for making string interpolation quasiquoters module Morley.Util.Interpolate.Internal- ( Transformation(..)- , Transformations- , transformationsPowerSet- , mkQuoter- , generateName+ ( module Morley.Util.Interpolate.Internal ) where import Prelude hiding (lift)
src/Morley/Util/Named.hs view
@@ -24,9 +24,11 @@ import Control.Lens (Iso', Wrapped(..), iso) import Data.Aeson (FromJSON, ToJSON) import Data.Data (Data)+import Data.Default (Default(..)) import Fmt (Buildable(..)) import GHC.TypeLits (KnownSymbol, symbolVal)-import Named (Name(..), NamedF(..), arg, argDef, argF, (!), (:!), (:?))+import Named (Name(..), NamedF(..), arg, argDef, argF, defaults, (!), (:!), (:?))+import Named.Internal (Defaults, Param) import Text.Show qualified as T import Morley.Util.Label (Label)@@ -124,3 +126,6 @@ deriving newtype instance ToJSON a => ToJSON (NamedF Maybe a name) deriving newtype instance FromJSON a => FromJSON (NamedF Identity a name) deriving newtype instance FromJSON a => FromJSON (NamedF Maybe a name)++instance f ~ Defaults => Default (Param f) where+ def = defaults
src/Morley/Util/Peano.hs view
@@ -100,6 +100,7 @@ import Unsafe.Coerce (unsafeCoerce) import Morley.Util.Sing (genSingletonsType)+import Morley.Util.StubbedProof import Morley.Util.Type (FailUnless, MockableConstraint(..)) -- This is very obviously a false positive.@@ -163,9 +164,8 @@ where go :: forall m. Natural -> SingNat m go = \case- 0 -> (unsafeCoerce Refl :: m :~: 'Z) |- SZ- n -> (unsafeCoerce Refl :: m :~: 'S (Decrement m)) |-- SS $ go @(Decrement m) (n - 1)+ 0 -> SZ \\ (unsafeCoerce Refl :: m :~: 'Z)+ n -> SS (go @(Decrement m) (n - 1)) \\ (unsafeCoerce Refl :: m :~: 'S (Decrement m)) -- | Run a computation requiring @SingI (ToPeano n)@ in a context which only has -- @KnownNat n@. Mostly useful when used with 'SomeNat'@@ -174,8 +174,8 @@ where go :: forall (m :: Peano). Natural -> Dict (SingI m) go = \case- 0 -> (unsafeCoerce Refl :: m :~: 'Z) |- Dict- n -> (unsafeCoerce Refl :: m :~: 'S (Decrement m)) |- (Dict \\ go @(Decrement m) (n - 1))+ 0 -> Dict \\ (unsafeCoerce Refl :: m :~: 'Z)+ n -> Dict \\ go @(Decrement m) (n - 1) \\ (unsafeCoerce Refl :: m :~: 'S (Decrement m)) -- | Lift a given term-level 'Natural' to the type level for a given computation. The computation is -- expected to accept a 'Proxy' for the sake of convenience: it's easier to get at the type-level@@ -241,9 +241,9 @@ -- | Singleton addition peanoSingAdd :: SingNat n -> SingNat m -> SingNat (AddPeano n m)-peanoSingAdd (SS n) (SS m) = associativity n m |- SS $ SS $ peanoSingAdd n m+peanoSingAdd (SS n) (SS (m :: SingNat m')) = SS (SS (peanoSingAdd n m)) \\ associativity @m' n peanoSingAdd SZ m = m-peanoSingAdd n SZ = commutativity n SZ |- n+peanoSingAdd n SZ = n \\ commutativity n SZ ---------------------------------------------------------------------------- -- Lists@@ -467,53 +467,50 @@ (|-) :: forall k (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r (|-) = gcastWith infixr 1 |-+{-# DEPRECATED (|-) "Just use (\\\\) from Data.Constraint." #-} -- | Proof that for naturals, @k + (m + 1) = n@ entails @n > k@-{-# RULES "additivity" forall k m n. additivity k m n = unsafeCoerce Refl #-}-{-# INLINE[1] additivity #-} additivity :: forall k m n. AddPeano k ('S m) ~ n- => SingNat m -> SingNat n -> SingNat k -> n > k :~: 'True-additivity _ (SS _) SZ = Refl-additivity m (SS _) k = associativity k m |- lemma2 @_ @m k |- lemma k |- Refl+ => SingNat k -> n > k :~: 'True+additivity k = stubProof $ case k of+ SZ -> Refl+ _ -> Refl \\ lemma k \\ lemma2 @_ @m k \\ associativity @m k where - lemma2 :: forall k' m'. SingNat k' -> 'S (AddPeano k' m') > k' :~: 'True- lemma2 SZ = Refl- lemma2 (SS k') = lemma2 @_ @m' k' |- Refl+ lemma2 :: forall k' m'. SingNat k' -> 'S (AddPeano k' m') > k' :~: 'True+ lemma2 SZ = Refl+ lemma2 (SS k') = Refl \\ lemma2 @_ @m' k' - lemma :: SingNat k' -> 'S k' > k' :~: 'True- lemma SZ = Refl- lemma (SS n) = lemma n |- Refl+ lemma :: SingNat k' -> 'S k' > k' :~: 'True+ lemma SZ = Refl+ lemma (SS n') = Refl \\ lemma n' -- | Proof that for naturals, @x + (y + 1) = (x + y) + 1@-{-# RULES "associativity" forall x y. associativity x y = unsafeCoerce Refl #-}-{-# INLINE[1] associativity #-}-associativity :: SingNat x -> SingNat y -> AddPeano x ('S y) :~: 'S (AddPeano x y)-associativity SZ _ = Refl-associativity (SS x) y = associativity x y |- Refl+associativity :: forall y x. SingNat x -> AddPeano x ('S y) :~: 'S (AddPeano x y)+associativity x = stubProof $ case x of+ SZ -> Refl+ SS x' -> Refl \\ associativity @y x' -- | Proof that @x + y = y + x@-{-# RULES "commutativity" forall x y. commutativity x y = unsafeCoerce Refl #-}-{-# INLINE[1] commutativity #-} commutativity :: SingNat x -> SingNat y -> AddPeano x y :~: AddPeano y x-commutativity SZ SZ = Refl-commutativity SZ (SS y) = commutativity SZ y |- Refl-commutativity (SS x) y = commutativity x y |- associativity y x |- Refl+commutativity x y = stubProof $ case x of+ SZ -> case y of+ SZ -> Refl+ SS y' -> Refl \\ commutativity x y'+ SS (x' :: SingNat x') -> Refl \\ associativity @x' y \\ commutativity x' y -- | Proof that for naturals, @min(n, n) = n@-{-# RULES "minIdempotency" forall x. minIdempotency x = unsafeCoerce Refl #-}-{-# INLINE[1] minIdempotency #-} minIdempotency :: SingNat n -> MinPeano n n :~: n-minIdempotency SZ = Refl-minIdempotency (SS n) = minIdempotency n |- Refl+minIdempotency n = stubProof $ case n of+ SZ -> Refl+ SS n' -> Refl \\ minIdempotency n' -- | Proof that for naturals, @x >= y > z@ implies @x > z@-{-# RULES "transitivity" forall x y z. transitivity x y z = unsafeCoerce Refl #-}-{-# INLINE[1] transitivity #-} transitivity :: (x >= y ~ 'True, y > z ~ 'True) => SingNat x -> SingNat y -> SingNat z -> x > z :~: 'True-transitivity (SS _) (SS _) SZ = Refl-transitivity (SS x) (SS y) (SS z) = transitivity x y z |- Refl+transitivity x y z = stubProof $ case (x, y, z) of+ (SS _, SS _, SZ) -> Refl+ (SS x', SS y', SS z') -> Refl \\ transitivity x' y' z' ---------------------------------------------------------------------------- -- Helpers
src/Morley/Util/PeanoNatural.hs view
@@ -16,12 +16,13 @@ , singPeanoVal , eqPeanoNat , singPeanoNat+ , addPeanoNat ) where import Data.Singletons (SingI(..)) import Data.Type.Equality (TestEquality(..), (:~:)) import GHC.TypeNats (Nat)-import Morley.Util.Peano (Peano, SingIPeano, SingNat(..), ToPeano, pattern S, pattern Z)+import Morley.Util.Peano import Text.PrettyPrint.Leijen.Text (integer) import Morley.Michelson.Printer.Util@@ -99,3 +100,6 @@ -- | Get a corresponding 'SingNat' from a 'PeanoNatural'. singPeanoNat :: PeanoNatural a -> SingNat a singPeanoNat (PN n _) = n++addPeanoNat :: PeanoNatural a -> PeanoNatural b -> PeanoNatural (AddPeano a b)+addPeanoNat (PN a n) (PN b m) = PN (peanoSingAdd a b) (n + m)
src/Morley/Util/SizedList.hs view
@@ -57,6 +57,7 @@ (drop, fromList, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) import Prelude qualified (fromList) +import Data.Constraint ((\\)) import Data.List qualified as List import Data.Singletons (SingI(..)) import Fmt (Buildable(..))@@ -69,6 +70,7 @@ -- -- >>> import Prelude hiding (drop, fromList, head, replicate, reverse, splitAt, tail, take, unzip, zip, zipWith) -- >>> import Morley.Util.Peano+-- >>> import Data.Constraint ((\\)) -- | The primary fixed-size list type. Parametrized by a type-level 'Nat' as length and type -- as element type.@@ -123,7 +125,7 @@ instance SingI n => Applicative (SizedList' n) where pure = replicate' (sing @n)- (<*>) = minIdempotency (sing @n) |- zipWith ($)+ (<*>) = zipWith ($) \\ minIdempotency (sing @n) instance SingI n => Monad (SizedList' n) where f >>= k = generate' (sing @n) $ \(r, _) -> index' r $ k (index' r f)@@ -286,9 +288,10 @@ go :: forall k m. (AddPeano k m ~ n) => Natural -> SingNat k -> SingNat m -> SizedList' m a go _ _ SZ = Nil- go i k (SS m) = additivity m n k |- associativity k m |-- f (k, i) :< go (i + 1) (SS k) m+ go i k (SS (m :: SingNat m')) =+ f (k, i) :< go (i + 1) (SS k) m \\ associativity @m' k \\ additivity @k @m' @n k + -- | Reverse a 'SizedList' -- -- >>> reverse $ generate @3 (+1)@@ -343,7 +346,7 @@ -- -- >>> let slLen = length' someList -- >>> let len = peanoSing @2--- >>> generate' @_ @Char len $ \(sg, _) -> transitivity slLen len sg |- index' sg someList+-- >>> generate' @_ @Char len $ \(sg, _) -> index' sg someList \\ transitivity slLen len sg -- 'a' :< 'b' :< Nil index' :: (m > n ~ 'True) => SingNat n -> SizedList' m a -> a index' SZ (x :< _)= x
+ src/Morley/Util/StubbedProof.hs view
@@ -0,0 +1,35 @@+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Utilities for (slightly unsafely) stubbing typelevel proofs.+module Morley.Util.StubbedProof+ ( assumeKnown+ , assumeSing+ , stubProof+ ) where++import Data.Singletons (Sing)+import Data.Type.Equality ((:~:)(..))+import GHC.Exts qualified as GHC (Any)+import Unsafe.Coerce (unsafeCoerce)++import Morley.Util.Type (KList(..))++-- | A class to constrain unsafe operations to a stubbed proof. 'GHC.Any' is+-- uninhabited, making it impossible to define an instance of this class.+class GHC.Any => Stubbed where+ -- | Assume a @KnownList@ by providing a fake 'KList'. Can only be done inside a+ -- 'Stubbed' proof. This is not entirely safe due to the existence of things+ -- like @Any@, and with enough effort one could theoretically get an+ -- 'unsafeCoerce' out of a proof that uses this, but arguably it's "safe+ -- enough".+ assumeKnown :: forall xs. KList xs++ -- | Assume @SingI@ by providing a fake 'Sing'. Can only be done inside a+ -- 'Stubbed' proof. Same caveats apply as with 'assumeKnown'.+ assumeSing :: forall x. Sing x++-- | Ignore the first argument and instead 'unsafeCoerce' the result. It is+-- assumed that the first argument constitutes a semi-proper proof.+stubProof :: forall a b. (Stubbed => a :~: b) -> a :~: b+stubProof _ = unsafeCoerce Refl
src/Morley/Util/Text.hs view
@@ -5,10 +5,18 @@ ( headToLower , surround , dquotes+ , stripFieldPrefix+ , dropPrefix+ , toCamel+ , Manip.toPascal+ , toSnake+ , toSpinal+ , lowerCaseCluster ) where -import Data.Char (toLower)+import Data.Char (isLower, isUpper, toLower) import Data.Text qualified as T+import Data.Text.Manipulate qualified as Manip -- | Leads first character of text to lower case. --@@ -23,3 +31,90 @@ dquotes :: (Semigroup a, IsString a) => a -> a dquotes = surround "\"" "\""++-- | Drops the field name prefix from a field.+--+-- We assume a convention of the prefix always being non-uppercase, and the+-- first letter of the actual field name being uppercase.+dropPrefix :: Text -> Text+dropPrefix = T.dropWhile (not . isUpper)++-- | Transform text to @camelCase@.+--+-- If the text starts with a single uppercase letter, it is lowercased. If it+-- starts with a cluster of non-lowercase letters, all but the last in the+-- cluster are lowercased.+--+-- >>> toCamel "MyField"+-- "myField"+-- >>> toCamel "USPosition"+-- "usPosition"+-- >>> toCamel "FA2Config"+-- "fa2Config"+toCamel :: Text -> Text+toCamel = Manip.toCamel . lowerCaseCluster++-- | Transform text to @snake_case@.+--+-- Non-lowercase clusters starting with an uppercase letter are treated as+-- separate words, except the last letter in the cluster.+--+-- >>> toSnake "MyField"+-- "my_field"+-- >>> toSnake "USPosition"+-- "us_position"+-- >>> toSnake "FA2Config"+-- "fa2_config"+-- >>> toSnake "MyUSPosition"+-- "my_us_position"+-- >>> toSnake "MyFie123d"+-- "my_fie123d"+toSnake :: Text -> Text+toSnake = T.intercalate "_" . fmap (Manip.toSnake . lowerCaseCluster) . Manip.splitWords++-- | Transform text to @spinal-case@.+--+-- Non-lowercase clusters starting with an uppercase letter are treated as+-- separate words, except the last letter in the cluster.+--+-- >>> toSpinal "MyField"+-- "my-field"+-- >>> toSpinal "USPosition"+-- "us-position"+-- >>> toSpinal "FA2Config"+-- "fa2-config"+-- >>> toSpinal "MyUSPosition"+-- "my-us-position"+-- >>> toSpinal "MyFie123d"+-- "my-fie123d"+toSpinal :: Text -> Text+toSpinal = T.intercalate "-" . fmap (Manip.toSpinal . lowerCaseCluster) . Manip.splitWords++-- | If text starts with a cluster of non-lowercase letters, lowercase them except+-- the last one.+--+-- >>> lowerCaseCluster "USPosition"+-- "usPosition"+-- >>> lowerCaseCluster "Position"+-- "Position"+-- >>> lowerCaseCluster "FA2Config"+-- "fa2Config"+lowerCaseCluster :: Text -> Text+lowerCaseCluster x = fromMaybe x do+ (c1, xs) <- T.uncons x+ (c2, _) <- T.uncons xs+ if notLower c1 && notLower c2+ then do+ let (ucs, rest) = T.span notLower x+ (ucs', lastuc) <- T.unsnoc ucs+ Just $ T.map toLower ucs' <> T.cons lastuc rest+ else Nothing+ where+ notLower = not . isLower++-- | Cut fields prefixes which we use according to the style guide.+--+-- >>> stripFieldPrefix "cmMyField"+-- "myField"+stripFieldPrefix :: Text -> Text+stripFieldPrefix = toCamel . dropPrefix
src/Morley/Util/Type.hs view
@@ -10,7 +10,6 @@ , IsElem , type (/) , type (//)- , AssertTypesEqual , FailUnlessEqual , FailUnlessEqualElse , FailWhen@@ -163,11 +162,6 @@ type FailUnlessEqual :: forall k. k -> k -> ErrorMessage -> Constraint type FailUnlessEqual a b err = FailUnlessEqualElse a b err () --- | An old name for 'FailUnlessEqual'.-type AssertTypesEqual :: forall k. k -> k -> ErrorMessage -> Constraint-type AssertTypesEqual a b err = FailUnlessEqual a b err-{-# DEPRECATED AssertTypesEqual "Use FailUnlessEqual instead" #-}- -- | A version of 'FailWhenElsePoly' that imposes an equality constraint on its -- 'Bool' argument. type FailWhenElse :: Bool -> ErrorMessage -> Constraint -> Constraint@@ -233,7 +227,7 @@ -- | A version of 'FailUnlessElsePoly' that imposes an equality constraint on its -- 'Bool' argument. type FailUnlessElse :: Bool -> ErrorMessage -> Constraint -> Constraint-type FailUnlessElse b msg els = FailWhenElse (Not b) msg els+type FailUnlessElse cond msg els = FailUnlessEqualElse cond 'True msg els -- | Fail with given error if the condition does not hold. Otherwise, -- return the third argument.@@ -251,9 +245,11 @@ -- | A natural conclusion from the fact that an error has not occurred. failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True) failUnlessEvi = Sub unsafeProvideConstraint+{-# DEPRECATED failUnlessEvi "FailUnless should carry the corresponding type equality already" #-} failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False) failWhenEvi = Sub unsafeProvideConstraint+{-# DEPRECATED failWhenEvi "FailWhen should carry the corresponding type equality already" #-} type family AllUnique (l :: [k]) :: Bool where AllUnique '[] = 'True@@ -342,6 +338,7 @@ recordToSomeList = recordToList . rmap (Vinyl.Const . Some1) type ConcatListOfTypesAssociativity a b c = ((a ++ b) ++ c) ~ (a ++ (b ++ c))+{-# DEPRECATED ConcatListOfTypesAssociativity "Unused; use the definition instead" #-} -- | GHC can't deduce this itself because -- in general a type family might be not associative,@@ -350,6 +347,9 @@ -- But (++) type family is associative, so let's define this small hack. listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c) listOfTypesConcatAssociativityAxiom = unsafeProvideConstraint+{-# DEPRECATED listOfTypesConcatAssociativityAxiom+ "Unused; a less ad-hoc version is available from \+ \Morley.Michelson.Typed.Instr.Internal.Proofs.assocThm" #-} -- | Constaints that can be provided on demand. --@@ -360,6 +360,8 @@ class MockableConstraint (c :: Constraint) where -- | Produce a constraint out of thin air. unsafeProvideConstraint :: Dict c+{-# DEPRECATED unsafeProvideConstraint+ "Apparently unused, and turns out to be very unsafe in practice." #-} instance MockableConstraint (a ~ b) where unsafeProvideConstraint = unsafeCoerce $ Dict @(Int ~ Int)
src/Morley/Util/TypeLits.hs view
@@ -14,13 +14,9 @@ , TypeError , ErrorMessage (..)-- , AssertTypesEqual ) where import GHC.TypeLits (AppendSymbol, ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)--import Morley.Util.Type (AssertTypesEqual) symbolValT :: forall s. KnownSymbol s => Proxy s -> Text symbolValT = toText . symbolVal