diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,111 @@ +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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 [![Hackage](https://img.shields.io/hackage/v/morley.svg)](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 --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). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/app/REPL.hs b/app/REPL.hs --- a/app/REPL.hs +++ b/app/REPL.hs @@ -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 $ diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -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 -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 diff --git a/src/Morley/AsRPC.hs b/src/Morley/AsRPC.hs --- a/src/Morley/AsRPC.hs +++ b/src/Morley/AsRPC.hs @@ -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) diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs --- a/src/Morley/CLI.hs +++ b/src/Morley/CLI.hs @@ -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" diff --git a/src/Morley/Micheline/Binary/Internal.hs b/src/Morley/Micheline/Binary/Internal.hs --- a/src/Morley/Micheline/Binary/Internal.hs +++ b/src/Morley/Micheline/Binary/Internal.hs @@ -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) diff --git a/src/Morley/Micheline/Class.hs b/src/Morley/Micheline/Class.hs --- a/src/Morley/Micheline/Class.hs +++ b/src/Morley/Micheline/Class.hs @@ -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 diff --git a/src/Morley/Micheline/Expression.hs b/src/Morley/Micheline/Expression.hs --- a/src/Morley/Micheline/Expression.hs +++ b/src/Morley/Micheline/Expression.hs @@ -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. diff --git a/src/Morley/Michelson/Internal/ViewName.hs b/src/Morley/Michelson/Internal/ViewName.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Michelson/Internal/ViewName.hs @@ -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 diff --git a/src/Morley/Michelson/Internal/ViewsSet.hs b/src/Morley/Michelson/Internal/ViewsSet.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Michelson/Internal/ViewsSet.hs @@ -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 diff --git a/src/Morley/Michelson/Interpret.hs b/src/Morley/Michelson/Interpret.hs --- a/src/Morley/Michelson/Interpret.hs +++ b/src/Morley/Michelson/Interpret.hs @@ -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 diff --git a/src/Morley/Michelson/Macro.hs b/src/Morley/Michelson/Macro.hs --- a/src/Morley/Michelson/Macro.hs +++ b/src/Morley/Michelson/Macro.hs @@ -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 -- diff --git a/src/Morley/Michelson/Optimizer.hs b/src/Morley/Michelson/Optimizer.hs --- a/src/Morley/Michelson/Optimizer.hs +++ b/src/Morley/Michelson/Optimizer.hs @@ -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 diff --git a/src/Morley/Michelson/Optimizer/Internal/Proofs.hs b/src/Morley/Michelson/Optimizer/Internal/Proofs.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Michelson/Optimizer/Internal/Proofs.hs @@ -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) diff --git a/src/Morley/Michelson/Parser.hs b/src/Morley/Michelson/Parser.hs --- a/src/Morley/Michelson/Parser.hs +++ b/src/Morley/Michelson/Parser.hs @@ -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 @@ -- 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 diff --git a/src/Morley/Michelson/Parser/Instr.hs b/src/Morley/Michelson/Parser/Instr.hs --- a/src/Morley/Michelson/Parser/Instr.hs +++ b/src/Morley/Michelson/Parser/Instr.hs @@ -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 diff --git a/src/Morley/Michelson/Parser/Type.hs b/src/Morley/Michelson/Parser/Type.hs --- a/src/Morley/Michelson/Parser/Type.hs +++ b/src/Morley/Michelson/Parser/Type.hs @@ -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" diff --git a/src/Morley/Michelson/Runtime.hs b/src/Morley/Michelson/Runtime.hs --- a/src/Morley/Michelson/Runtime.hs +++ b/src/Morley/Michelson/Runtime.hs @@ -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 diff --git a/src/Morley/Michelson/Runtime/Dummy.hs b/src/Morley/Michelson/Runtime/Dummy.hs --- a/src/Morley/Michelson/Runtime/Dummy.hs +++ b/src/Morley/Michelson/Runtime/Dummy.hs @@ -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 diff --git a/src/Morley/Michelson/Runtime/GState.hs b/src/Morley/Michelson/Runtime/GState.hs --- a/src/Morley/Michelson/Runtime/GState.hs +++ b/src/Morley/Michelson/Runtime/GState.hs @@ -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 "" 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 "" 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 diff --git a/src/Morley/Michelson/Runtime/RunCode.hs b/src/Morley/Michelson/Runtime/RunCode.hs --- a/src/Morley/Michelson/Runtime/RunCode.hs +++ b/src/Morley/Michelson/Runtime/RunCode.hs @@ -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, diff --git a/src/Morley/Michelson/TypeCheck/Error.hs b/src/Morley/Michelson/TypeCheck/Error.hs --- a/src/Morley/Michelson/TypeCheck/Error.hs +++ b/src/Morley/Michelson/TypeCheck/Error.hs @@ -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 diff --git a/src/Morley/Michelson/TypeCheck/Helpers.hs b/src/Morley/Michelson/TypeCheck/Helpers.hs --- a/src/Morley/Michelson/TypeCheck/Helpers.hs +++ b/src/Morley/Michelson/TypeCheck/Helpers.hs @@ -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." diff --git a/src/Morley/Michelson/TypeCheck/Instr.hs b/src/Morley/Michelson/TypeCheck/Instr.hs --- a/src/Morley/Michelson/TypeCheck/Instr.hs +++ b/src/Morley/Michelson/TypeCheck/Instr.hs @@ -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 $ diff --git a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs --- a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs +++ b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs @@ -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) diff --git a/src/Morley/Michelson/TypeCheck/Value.hs b/src/Morley/Michelson/TypeCheck/Value.hs --- a/src/Morley/Michelson/TypeCheck/Value.hs +++ b/src/Morley/Michelson/TypeCheck/Value.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Annotation.hs b/src/Morley/Michelson/Typed/Annotation.hs --- a/src/Morley/Michelson/Typed/Annotation.hs +++ b/src/Morley/Michelson/Typed/Annotation.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Arith.hs b/src/Morley/Michelson/Typed/Arith.hs --- a/src/Morley/Michelson/Typed/Arith.hs +++ b/src/Morley/Michelson/Typed/Arith.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs --- a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs +++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs --- a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs +++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs --- a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs +++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Contract.hs b/src/Morley/Michelson/Typed/Contract.hs --- a/src/Morley/Michelson/Typed/Contract.hs +++ b/src/Morley/Michelson/Typed/Contract.hs @@ -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." #-} diff --git a/src/Morley/Michelson/Typed/Convert.hs b/src/Morley/Michelson/Typed/Convert.hs --- a/src/Morley/Michelson/Typed/Convert.hs +++ b/src/Morley/Michelson/Typed/Convert.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Extract.hs b/src/Morley/Michelson/Typed/Extract.hs --- a/src/Morley/Michelson/Typed/Extract.hs +++ b/src/Morley/Michelson/Typed/Extract.hs @@ -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) diff --git a/src/Morley/Michelson/Typed/Haskell/Doc.hs b/src/Morley/Michelson/Typed/Haskell/Doc.hs --- a/src/Morley/Michelson/Typed/Haskell/Doc.hs +++ b/src/Morley/Michelson/Typed/Haskell/Doc.hs @@ -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" diff --git a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs --- a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs +++ b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs @@ -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 = diff --git a/src/Morley/Michelson/Typed/Haskell/Value.hs b/src/Morley/Michelson/Typed/Haskell/Value.hs --- a/src/Morley/Michelson/Typed/Haskell/Value.hs +++ b/src/Morley/Michelson/Typed/Haskell/Value.hs @@ -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) diff --git a/src/Morley/Michelson/Typed/Instr.hs b/src/Morley/Michelson/Typed/Instr.hs --- a/src/Morley/Michelson/Typed/Instr.hs +++ b/src/Morley/Michelson/Typed/Instr.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Instr/Constraints.hs b/src/Morley/Michelson/Typed/Instr/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Michelson/Typed/Instr/Constraints.hs @@ -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) diff --git a/src/Morley/Michelson/Typed/Instr/Internal/Proofs.hs b/src/Morley/Michelson/Typed/Instr/Internal/Proofs.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Michelson/Typed/Instr/Internal/Proofs.hs @@ -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) diff --git a/src/Morley/Michelson/Typed/Operation.hs b/src/Morley/Michelson/Typed/Operation.hs --- a/src/Morley/Michelson/Typed/Operation.hs +++ b/src/Morley/Michelson/Typed/Operation.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Scope.hs b/src/Morley/Michelson/Typed/Scope.hs --- a/src/Morley/Michelson/Typed/Scope.hs +++ b/src/Morley/Michelson/Typed/Scope.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/T.hs b/src/Morley/Michelson/Typed/T.hs --- a/src/Morley/Michelson/Typed/T.hs +++ b/src/Morley/Michelson/Typed/T.hs @@ -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) diff --git a/src/Morley/Michelson/Typed/Util.hs b/src/Morley/Michelson/Typed/Util.hs --- a/src/Morley/Michelson/Typed/Util.hs +++ b/src/Morley/Michelson/Typed/Util.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/Value.hs b/src/Morley/Michelson/Typed/Value.hs --- a/src/Morley/Michelson/Typed/Value.hs +++ b/src/Morley/Michelson/Typed/Value.hs @@ -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 diff --git a/src/Morley/Michelson/Typed/View.hs b/src/Morley/Michelson/Typed/View.hs --- a/src/Morley/Michelson/Typed/View.hs +++ b/src/Morley/Michelson/Typed/View.hs @@ -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 diff --git a/src/Morley/Michelson/Untyped/Contract.hs b/src/Morley/Michelson/Untyped/Contract.hs --- a/src/Morley/Michelson/Untyped/Contract.hs +++ b/src/Morley/Michelson/Untyped/Contract.hs @@ -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' diff --git a/src/Morley/Michelson/Untyped/Instr.hs b/src/Morley/Michelson/Untyped/Instr.hs --- a/src/Morley/Michelson/Untyped/Instr.hs +++ b/src/Morley/Michelson/Untyped/Instr.hs @@ -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 diff --git a/src/Morley/Michelson/Untyped/Type.hs b/src/Morley/Michelson/Untyped/Type.hs --- a/src/Morley/Michelson/Untyped/Type.hs +++ b/src/Morley/Michelson/Untyped/Type.hs @@ -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) diff --git a/src/Morley/Michelson/Untyped/Value.hs b/src/Morley/Michelson/Untyped/Value.hs --- a/src/Morley/Michelson/Untyped/Value.hs +++ b/src/Morley/Michelson/Untyped/Value.hs @@ -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) diff --git a/src/Morley/Michelson/Untyped/View.hs b/src/Morley/Michelson/Untyped/View.hs --- a/src/Morley/Michelson/Untyped/View.hs +++ b/src/Morley/Michelson/Untyped/View.hs @@ -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 diff --git a/src/Morley/Tezos/Address.hs b/src/Morley/Tezos/Address.hs --- a/src/Morley/Tezos/Address.hs +++ b/src/Morley/Tezos/Address.hs @@ -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 diff --git a/src/Morley/Tezos/Address/Alias.hs b/src/Morley/Tezos/Address/Alias.hs --- a/src/Morley/Tezos/Address/Alias.hs +++ b/src/Morley/Tezos/Address/Alias.hs @@ -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 diff --git a/src/Morley/Tezos/Address/Kinds.hs b/src/Morley/Tezos/Address/Kinds.hs --- a/src/Morley/Tezos/Address/Kinds.hs +++ b/src/Morley/Tezos/Address/Kinds.hs @@ -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 + |] diff --git a/src/Morley/Tezos/Crypto.hs b/src/Morley/Tezos/Crypto.hs --- a/src/Morley/Tezos/Crypto.hs +++ b/src/Morley/Tezos/Crypto.hs @@ -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 diff --git a/src/Morley/Tezos/Crypto/BLS.hs b/src/Morley/Tezos/Crypto/BLS.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Tezos/Crypto/BLS.hs @@ -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 diff --git a/src/Morley/Tezos/Crypto/Util.hs b/src/Morley/Tezos/Crypto/Util.hs --- a/src/Morley/Tezos/Crypto/Util.hs +++ b/src/Morley/Tezos/Crypto/Util.hs @@ -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 diff --git a/src/Morley/Util/CLI.hs b/src/Morley/Util/CLI.hs --- a/src/Morley/Util/CLI.hs +++ b/src/Morley/Util/CLI.hs @@ -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. diff --git a/src/Morley/Util/Interpolate/Internal.hs b/src/Morley/Util/Interpolate/Internal.hs --- a/src/Morley/Util/Interpolate/Internal.hs +++ b/src/Morley/Util/Interpolate/Internal.hs @@ -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) diff --git a/src/Morley/Util/Named.hs b/src/Morley/Util/Named.hs --- a/src/Morley/Util/Named.hs +++ b/src/Morley/Util/Named.hs @@ -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 diff --git a/src/Morley/Util/Peano.hs b/src/Morley/Util/Peano.hs --- a/src/Morley/Util/Peano.hs +++ b/src/Morley/Util/Peano.hs @@ -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 diff --git a/src/Morley/Util/PeanoNatural.hs b/src/Morley/Util/PeanoNatural.hs --- a/src/Morley/Util/PeanoNatural.hs +++ b/src/Morley/Util/PeanoNatural.hs @@ -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) diff --git a/src/Morley/Util/SizedList.hs b/src/Morley/Util/SizedList.hs --- a/src/Morley/Util/SizedList.hs +++ b/src/Morley/Util/SizedList.hs @@ -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 diff --git a/src/Morley/Util/StubbedProof.hs b/src/Morley/Util/StubbedProof.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Util/StubbedProof.hs @@ -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 diff --git a/src/Morley/Util/Text.hs b/src/Morley/Util/Text.hs --- a/src/Morley/Util/Text.hs +++ b/src/Morley/Util/Text.hs @@ -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 diff --git a/src/Morley/Util/Type.hs b/src/Morley/Util/Type.hs --- a/src/Morley/Util/Type.hs +++ b/src/Morley/Util/Type.hs @@ -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) diff --git a/src/Morley/Util/TypeLits.hs b/src/Morley/Util/TypeLits.hs --- a/src/Morley/Util/TypeLits.hs +++ b/src/Morley/Util/TypeLits.hs @@ -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