diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -2,11 +2,54 @@ ========== +1.1.0 +===== +* [!306](https://gitlab.com/morley-framework/morley/-/merge_requests/306) + Added PAIR/UNPAIR rule to optimizer. +* [!314](https://gitlab.com/morley-framework/morley/-/merge_requests/314) + Fixed a bug in the implementation of `MAP` operation: it did not preserve modifications to + stack. +* [!261](https://gitlab.com/morley-framework/morley/merge_requests/261) + Slightly modified interpreter API. +* [!313](https://gitlab.com/morley-framework/morley/-/merge_requests/313) + Made `typeCheckValue` polymorphic in desired type, instead of using + existential wrappers. +* [!310](https://gitlab.com/morley-framework/morley/merge_requests/232) + + Add `DGeneralInfoSection` documentation section with git revision and + potentially other info. + + Add `buildLorentzDocWithGitRev` and `buildInstrDocWithGitRev` to + API to add a git revision to contract docs from the executable. +* [!121](https://gitlab.com/morley-framework/morley/merge_requests/302) + `BALANCE` instruction now returns the balance with funds from incoming + transaction. +* [!294](https://gitlab.com/morley-framework/morley/-/merge_requests/294) + + Added `Paths_*` modules to `autogen-modules` in cabal files. Removed `-O0` + + from default GHC options. Please set `ghc-options` in your `stack.yaml` or + `cabal.project.local`. +* [!271](https://gitlab.com/morley-framework/morley/merge_requests/271) Renamed + 'Contract' to 'ContractCode', and appended "Code" to the names of two functions: + 'convertContract' and 'printTypedContract' +* [!278](https://gitlab.com/morley-framework/morley/merge_requests/278) + Added some utilities for command line option parsing, see `Util.CLI` and `Morley.CLI` modules. +* [!268](https://gitlab.com/morley-framework/morley/merge_requests/268) + Test functions which import typed contract now return `FullContract` instead + of `Contract`, thus preserving parameter and storage annotations. In case you + don't need this behaviour, use `fcCode` for conversion. + Test functions which import Lorentz contracts have been removed because they + cannot be implemented sanely, and Lorentz is assumed to be used to generate + code, do not use it for work with textual Michelson contracts. +* [!212](https://gitlab.com/morley-framework/morley/merge_requests/212) + + Fix `AND` instruction return type. + + Add `DUP n` macro support. + + Fix `LAMBDA` instruction printer. +* [!265](https://gitlab.com/morley-framework/morley/merge_requests/265) + The semicolons between instructions are now optional. + 1.0.0 ===== * [!215](https://gitlab.com/morley-framework/morley/merge_requests/215) - Major change: all Lorentz functionality was moved into `morley-lorentz` package. + Major change: all Lorentz functionality was moved into `lorentz` package. A small portion of testing library code was moved around (from `Lorentz.*` to `Michelson.*` or vice versa). 0.7.0 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md deleted file mode 100644 --- a/CONTRIBUTING.md +++ /dev/null @@ -1,84 +0,0 @@ -# Contribution Guidelines - -## Reporting Issues - -Please [open an issue](https://gitlab.com/morley-framework/morley/issues/new) -if you find a bug or have a feature request. -Before submitting a bug report or feature request, check to make sure it hasn't already been submitted. - -The more detailed your report is, the faster it can be resolved. -Please use issue templates to create an issue. - -## Code - -If you would like to contribute code to fix a bug, add a new feature, or -otherwise improve our project, merge requests are most welcome. - -Our merge request template contains a [checklist](/.gitlab/merge_request_templates/default.md#white_check_mark-checklist-for-your-merge-request) of acceptance criteria for your merge request. -Please read it before you start contributing and make sure your contributions adhere to this checklist. - -### Prelude - -All Haskell code uses -[Universum](https://hackage.haskell.org/package/universum) as a -replacement for the default prelude. - -### Tests - -We use [`tasty`](https://hackage.haskell.org/package/tasty) as our primary top-level testing framework. -Some old code may use `hspec` instead, but all new code must use `tasty`. -We use [`tasty-discover`](https://hackage.haskell.org/package/tasty-discover) to automatically find all tests. -We still require explicit exports to ensure that we don't accidentally miss some test. -If we accidentally name some test in a way which will be ignored by `tasty-discover`, `weeder` will detect a useless export. - -Some hints regarding `tasty` and our test-suite: -1. You can use `--hide-successes` to see only failing tests. -It's useful because otherwise if test suite fails you need to find the cause of failure manually. -2. However, beware of [this issue](https://github.com/feuerbach/tasty/issues/152) with `--hide-successes`. -In short, this option is somewhat broken when `tasty` thinks that it outputs to console. -A workaround is to set `TERM=dumb`. -3. You can run tests using our `Makefile`, see below. - -## Cabal and Stack - -We use [`hpack`](https://hackage.haskell.org/package/hpack) and `stack.yaml` to maintain the project -and its dependencies, but we also provide `.cabal` files in the repository due to -[stack issue](https://github.com/commercialhaskell/stack/issues/4906) which makes it impossible -to use `morley` as a dependency with stack version > 2 without `.cabal` files. Also we provide -`cabal.project` and `cabal.project.freeze` files in order to provide an ability to build the -project using `cabal`. If you want to update dependencies in one of these cabal related files you -should transfer changes to `package.yaml` or `stack.yaml` and run [`scripts/generate-cabal-files.sh`](scripts/generate-cabal-files.sh), -this script will update these files. - -## Makefile - -We have a [Makefile](/Makefile) which provides shortcuts for the most -common developers' activities, like building with flags suitable for -development, testing, applying `stylish-haskell` and `hlint`, building -Haddock documentation. Mentioned `Makefile` builds morley itself, -each extra package, like [`morley-ledgers`](/morley-ledgers/Makefile), -has its own `Makefile`. - -If you want to run test suite with additional options, set `TEST_ARGUMENTS` variable. -Example: `TEST_ARGUMENTS="--pattern Parser" make test`. -If you want to enable `--hide-successes` option, you can use `make test-hide-successes`. -It will automatically set `TERM=dumb` which is a workaround for the issue mentioned earlier. - -## Branching policy - -Our branching policy is described [here](/docs/branching.md). - -## Build recomendations - -### Emacs intero - -As soon as this repository uses different default extensions in different packages, -Intero may report non-existing errors. -This issue is known (once located under https://github.com/chrisdone/intero/issues/554) -and will never be resolved unless `intero` project is resurrected. - -However, with proper care, this problem can be avoided. Just follow the rules: -* When working with `morley` package, select only `morley:*` packages in `intero-targets`. -* When developing on Lorentz within e. g. `morley-ledgers` package, make sure that -you first built morley core with `make morley`, only after that open the Lorentz modules. -Then set `morley-ledgers:*` packages as intero targets. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,13 +9,13 @@ It consists of the following parts: -- [`Tezos.*`](/src/Tezos/) hierarchy 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. -- [`Michelson.Untyped`](/src/Michelson/Untyped.hs) and [`Michelson.Typed`](src/Michelson/Typed.hs) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md). -- [`Michelson.TypeCheck`](/src/Michelson/TypeCheck.hs): A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md). -- [`Michelson.Interpret`](/src/Michelson/Interpret.hs): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md). -- [`Michelson.Macro`](/src/Michelson/Macro.hs) Types for macros, syntactic sugar, and other extensions that are described in the next chapter. -- [`Michelson.Parser`](/src/Michelson/Parser.hs) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT. -- [`Michelson.Runtime`](/src/Michelson/Runtime.hs): A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md). +- [`Tezos.*`](src/Tezos/) hierarchy 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. +- [`Michelson.Untyped`](src/Michelson/Untyped.hs) and [`Michelson.Typed`](src/Michelson/Typed.hs) hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md). +- [`Michelson.TypeCheck`](src/Michelson/TypeCheck.hs): A typechecker that validates Michelson contracts according to the Michelson's typing rules. Essentially, it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md). +- [`Michelson.Interpret`](src/Michelson/Interpret.hs): An interpreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md). +- [`Michelson.Macro`](src/Michelson/Macro.hs) Types for macros, syntactic sugar, and other extensions that are described in the next chapter. +- [`Michelson.Parser`](src/Michelson/Parser.hs) A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT. +- [`Michelson.Runtime`](src/Michelson/Runtime.hs): A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md). ## II: Morley extensions @@ -69,31 +69,12 @@ + `stack exec -- morley --help` to see help message + `stack exec -- morley originate --contract contracts/tezos_examples/attic/add1.tz --storage 1 --verbose` - [Cabal](https://www.haskell.org/cabal/) based. - * Clone this git repository and run `cabal new-update && cabal new-build` command, - after that you can do `cabal run -- morley ` to run morley executable built from the source code. + * Clone this git repository, go to this directory and run `cabal new-update && cabal new-build` command, + after that you can do `cabal new-run -- morley ` to run morley executable built from the source code. * Usage example: - + `cabal run -- morley --help` to see help message - + `cabal run -- morley originate --contract contracts/tezos_examples/attic/add1.tz --storage 1 --verbose` + + `cabal new-run -- morley --help` to see help message + + `cabal new-run -- morley originate --contract contracts/tezos_examples/attic/add1.tz --storage 1 --verbose` For more information about Morley commands, check out the following docs: - [Interpreter doc](/docs/morleyInterpreter.md) - [Typechecker doc](/docs/morleyTypechecker.md) - -## Michelson version - -`master` and `production` branches are maintained to be compatible with version of Michelson running on mainnet. -We use separate branches to support other versions. -More information about our branching strategy can be found [here](/docs/branching.md). - -## Issue Tracker - -We used to use [YouTrack](https://issues.serokell.io/issues/TM) as our primary issue tracker. -You may see that commit messages up to some date are prefixed with `[TM-X]`. -This prefix refers to an issue in our YouTrack. -YouTrack issues are public, so you can open any of them. - -Nowadays we are using built-in issue tracker on GitLab. - -## For Contributors - -Please see [CONTRIBUTING.md](CONTRIBUTING.md) for more information. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,39 +2,35 @@ ( main ) where -import qualified Control.Exception as E import Data.Version (showVersion) import Fmt (pretty) import Named ((:!), (:?), arg, argF, (!)) import Options.Applicative - (auto, command, eitherReader, execParser, footerDoc, fullDesc, header, help, helper, info, - infoOption, long, maybeReader, metavar, option, progDesc, readerError, short, showDefault, - showDefaultWith, strOption, subparser, switch, value) + (command, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, + progDesc, short, subparser, switch) import qualified Options.Applicative as Opt import Options.Applicative.Help.Pretty (Doc, linebreak) import Paths_morley (version) -import System.Exit (ExitCode) import System.IO (utf8) import Text.Pretty.Simple (pPrint) -import qualified Text.Show import Michelson.Analyzer (analyze) import Michelson.Macro (expandContract) import Michelson.Optimizer (optimize) -import qualified Michelson.Parser as P import Michelson.Printer (printSomeContract, printUntypedContract) import Michelson.Runtime (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer, typeCheckWithDb) import Michelson.Runtime.GState (genesisAddress) import Michelson.TypeCheck.Types (SomeContract(..), mapSomeContract) -import Michelson.Typed (FullContract(..), epNameFromRefAnn) -import Michelson.Untyped hiding (OriginationOperation(..)) +import Michelson.Typed (FullContract(..)) import qualified Michelson.Untyped as U -import Tezos.Address (Address, parseAddress) -import Tezos.Core - (Mutez, Timestamp(..), mkMutez, parseTimestamp, timestampFromSeconds, unMutez, unsafeMkMutez) +import Morley.CLI +import Tezos.Address (Address) +import Tezos.Core (Mutez, Timestamp(..), unsafeMkMutez) import Tezos.Crypto +import Util.CLI (outputOption) +import Util.Exception (displayUncaughtException) import Util.IO (hSetTranslit, withEncoding, writeFileUtf8) import Util.Named @@ -130,7 +126,7 @@ printSubCmd = mkCommandParser "print" - (Print <$> (#input <.?> contractFileOption) + (Print <$> (#input <.?> optional contractFileOption) <*> (#output <.?> outputOption) <*> (#singleLine <.!> onelineOption)) ("Parse a Morley contract and print corresponding Michelson " <> @@ -180,13 +176,13 @@ typeCheckOptions :: Opt.Parser TypeCheckOptions typeCheckOptions = TypeCheckOptions - <$> contractFileOption + <$> optional contractFileOption <*> dbPathOption <*> verboseFlag parseOptions :: Opt.Parser (Maybe FilePath, Bool) parseOptions = (,) - <$> contractFileOption + <$> optional contractFileOption <*> switch ( long "expand-macros" <> help "Whether expand macros after parsing or not") @@ -196,215 +192,60 @@ optimizeOptions :: Opt.Parser OptimizeOptions optimizeOptions = OptimizeOptions - <$> contractFileOption + <$> optional contractFileOption <*> dbPathOption <*> outputOption <*> onelineOption analyzeOptions :: Opt.Parser AnalyzeOptions analyzeOptions = AnalyzeOptions - <$> contractFileOption + <$> optional contractFileOption <*> dbPathOption runOptions :: Opt.Parser RunOptions runOptions = RunOptions - <$> contractFileOption + <$> optional contractFileOption <*> dbPathOption - <*> valueOption "storage" "Initial storage of a running contract" - <*> txData + <*> valueOption Nothing (#name .! "storage") + (#help .! "Initial storage of a running contract") + <*> txDataOption <*> verboseFlag <*> nowOption <*> maxStepsOption <*> mutezOption (Just defaultBalance) - "balance" "Initial balance of this contract" + (#name .! "balance") (#help .! "Initial balance of this contract") <*> writeFlag originateOptions :: Opt.Parser OriginateOptions originateOptions = OriginateOptions - <$> contractFileOption + <$> optional contractFileOption <*> dbPathOption - <*> addressOption (Just genesisAddress) "originator" "Contract's originator" + <*> addressOption (Just genesisAddress) + (#name .! "originator") (#help .! "Contract's originator") <*> optional - (keyHashOption Nothing "delegate" "Contract's optional delegate") - <*> valueOption "storage" "Initial storage of an originating contract" + (keyHashOption Nothing + (#name .! "delegate") (#help .! "Contract's optional delegate") + ) + <*> valueOption Nothing + (#name .! "storage") (#help .! "Initial storage of an originating contract") <*> mutezOption (Just defaultBalance) - "balance" "Initial balance of an originating contract" + (#name .! "balance") (#help .! "Initial balance of an originating contract") <*> verboseFlag transferOptions :: Opt.Parser TransferOptions transferOptions = do toDBPath <- dbPathOption - toDestination <- addressOption Nothing "to" "Destination address" - toTxData <- txData + toDestination <- + addressOption Nothing + (#name .! "to") (#help .! "Destination address") + toTxData <- txDataOption toNow <- nowOption toMaxSteps <- maxStepsOption toVerbose <- verboseFlag toDryRun <- dryRunFlag pure TransferOptions {..} - - -contractFileOption :: Opt.Parser (Maybe FilePath) -contractFileOption = optional $ strOption $ - long "contract" <> - metavar "FILEPATH" <> - help "Path to contract file" - -nowOption :: Opt.Parser (Maybe Timestamp) -nowOption = optional $ option parser $ - long "now" <> - metavar "TIMESTAMP" <> - help "Timestamp that you want the runtime interpreter to use (default is now)" - where - parser = - (timestampFromSeconds <$> auto) <|> - maybeReader (parseTimestamp . toText) - -maxStepsOption :: Opt.Parser Word64 -maxStepsOption = option auto $ - value 100500 <> - long "max-steps" <> - metavar "INT" <> - help "Max steps that you want the runtime interpreter to use" <> - showDefault - -dbPathOption :: Opt.Parser FilePath -dbPathOption = strOption $ - long "db" <> - metavar "FILEPATH" <> - value "db.json" <> - help "Path to DB with data which is used instead of real blockchain data" <> - showDefault - -keyHashOption :: Maybe KeyHash -> String -> String -> Opt.Parser KeyHash -keyHashOption defaultValue name hInfo = - option (eitherReader (first pretty . parseKeyHash . toText)) $ - long name <> - maybeAddDefault pretty defaultValue <> - help hInfo - -valueOption :: String -> String -> Opt.Parser U.Value -valueOption name hInfo = option (eitherReader parseValue) $ - long name <> - help hInfo - where - parseValue :: String -> Either String U.Value - parseValue = - first (mappend "Failed to parse value: " . displayException) . - P.parseExpandValue . - toText - -mutezOption :: Maybe Mutez -> String -> String -> Opt.Parser Mutez -mutezOption defaultValue name hInfo = - option (maybe (readerError "Invalid mutez") pure . mkMutez =<< auto) $ - long name <> - metavar "INT" <> - maybeAddDefault (show . unMutez) defaultValue <> - help hInfo - -addressOption :: Maybe Address -> String -> String -> Opt.Parser Address -addressOption defAddress name hInfo = - option (eitherReader parseAddrDo) $ mconcat - [ long name - , metavar "ADDRESS" - , help hInfo - , maybeAddDefault pretty defAddress - ] - where - parseAddrDo addr = - either (Left . mappend "Failed to parse address: " . pretty) Right $ - parseAddress $ toText addr - -onelineOption :: Opt.Parser Bool -onelineOption = switch ( - long "oneline" <> - help "Force single line output") - -outputOption :: Opt.Parser (Maybe FilePath) -outputOption = optional . strOption $ - short 'o' <> - long "output" <> - metavar "FILEPATH" <> - help "Write output to the given file. If not specified, stdout is used." - -entrypointOption :: String -> String -> Opt.Parser EpName -entrypointOption name hInfo = - option (eitherReader parseEntrypointDo) $ mconcat - [ long name - , metavar "ENTRYPOINT" - , help hInfo - , value DefEpName - , showDefaultWith pretty - ] - where - parseEntrypointDo (toText -> txt) = do - an <- - mkAnnotation txt - & first (mappend "Failed to parse entrypoint: " . pretty) - epNameFromRefAnn an - & first pretty - -txData :: Opt.Parser TxData -txData = - mkTxData - <$> addressOption (Just genesisAddress) "sender" "Sender address" - <*> valueOption "parameter" "Parameter of passed contract" - <*> mutezOption (Just minBound) "amount" "Amout sent by a transaction" - <*> entrypointOption "entrypoint" "Entrypoint to call" - where - mkTxData :: Address -> Value -> Mutez -> EpName -> TxData - mkTxData addr param amount epName = - TxData - { tdSenderAddress = addr - , tdParameter = param - , tdEntrypoint = epName - , tdAmount = amount - } - --- Maybe add default value and make sure it will be shown in help message. -maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a -maybeAddDefault printer = maybe mempty addDefault - where - addDefault v = value v <> showDefaultWith printer - ----------------------------------------------------------------------------- --- Better printing of exceptions ----------------------------------------------------------------------------- - -newtype DisplayExceptionInShow = DisplayExceptionInShow SomeException - -instance Show DisplayExceptionInShow where - show (DisplayExceptionInShow se) = displayException se - -instance Exception DisplayExceptionInShow - --- | Customise default uncaught exception handling. The problem with --- the default handler is that it uses `show` to display uncaught --- exceptions, but `displayException` may provide more reasonable --- output. We do not modify uncaught exception handler, but simply --- wrap uncaught exceptions (only synchronous ones) into --- 'DisplayExceptionInShow'. --- --- Some exceptions (currently we are aware only of 'ExitCode') are --- handled specially by default exception handler, so we don't wrap --- them. -displayUncaughtException :: IO () -> IO () -displayUncaughtException = mapIOExceptions wrapUnlessExitCode - where - -- We can't use `mapException` here, because it only works with - -- exceptions inside pure values, not with `IO` exceptions. - -- Note: it doesn't catch async exceptions. - mapIOExceptions :: (SomeException -> SomeException) -> IO a -> IO a - mapIOExceptions f action = action `catchAny` (E.throwIO . f) - - -- We don't wrap `ExitCode` because it seems to be handled specially. - -- Application exit code depends on the value stored in `ExitCode`. - wrapUnlessExitCode :: SomeException -> SomeException - wrapUnlessExitCode e = - case fromException @ExitCode e of - Just _ -> e - Nothing -> toException $ DisplayExceptionInShow e ---------------------------------------------------------------------------- -- Actual main diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,70 @@ +module Main (main) where + +import qualified Data.Map as M +import Gauge.Main (bench, nf, defaultMain, bgroup) +import Text.Megaparsec (parse) + +import Michelson.Interpret (interpret) +import Michelson.Parser as P +import Michelson.Runtime (prepareContract) +import Michelson.Test.Import +import Michelson.Test.Dummy +import Michelson.Text +import Michelson.TypeCheck as T +import Michelson.Typed as T +import Tezos.Address +import Util.IO + +main :: IO () +main = do + let + basicFp = "../../contracts/basic1.tz" + stringCallerFp = "../../contracts/string_caller.tz" + callSelfFp = "../../contracts/call_self_several_times.tz" + sq2Fp = "../../contracts/testassert_square2.mtz" + contractPaths = [basicFp, stringCallerFp, callSelfFp, sq2Fp] + contracts <- traverse (\x -> (x,) <$> readFileUtf8 x) contractPaths + let makeParseBench (filename, code) = + bench filename $ nf (parse P.program filename) code + preparedContracts <- evaluateNF =<< traverse (\x -> (x,) <$> prepareContract (Just x)) contractPaths + let + makeTypeCheckBench (filename, contract) = bench filename $ + nf (T.typeCheckContract (M.fromList [])) contract + + (_, basicC) <- importContract basicFp + (_, stringCallerC) <- importContract stringCallerFp + (_, callSelfC) <- importContract callSelfFp + (_, sq2C) <- importContract sq2Fp + let + basicBench = bench basicFp + (nf + (interpret (T.fcCode basicC) T.epcPrimitive T.VUnit (T.VList [T.VC (T.CvInt 0)])) + dummyContractEnv + ) + + dummyAddress = detGenKeyAddress "thegreatandpowerful" + dummyString = mkMTextUnsafe "TGAP" + stringCallerBench = bench stringCallerFp + (nf + (interpret (T.fcCode stringCallerC) T.epcPrimitive (T.toVal dummyString) (T.toVal dummyAddress)) + dummyContractEnv + ) + callSelfBench = bench callSelfFp + (nf + (interpret (T.fcCode callSelfC) T.epcPrimitive (T.toVal (100 :: Integer)) (T.toVal (0 :: Natural))) + dummyContractEnv + ) + + sq2Bench = bench sq2Fp + (nf + (interpret (T.fcCode sq2C) T.epcPrimitive (T.toVal (100 :: Integer, 200 :: Integer)) T.VUnit) + dummyContractEnv + ) + + + + defaultMain + [ bgroup "parsing" $ map makeParseBench contracts + , bgroup "type-checking" $ map makeTypeCheckBench preparedContracts + , bgroup "interpreting" $ [basicBench, stringCallerBench, callSelfBench, sq2Bench] + ] diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -1,13 +1,13 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.32.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 0e0daabc72a430afec07d1e179157ea8879f37c1581d88a8ce1fd0bd1410264d +-- hash: c1daa2d2e51ff7183ee4cf60a81aeda135b69cb2410f30184efbebe64c69710c name: morley -version: 1.0.0 +version: 1.1.0 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 @@ -21,7 +21,6 @@ build-type: Simple extra-source-files: CHANGES.md - CONTRIBUTING.md README.md source-repository head @@ -109,6 +108,8 @@ Michelson.Untyped.Instr Michelson.Untyped.Type Michelson.Untyped.Value + Morley.CLI + Morley.Micheline Tezos.Address Tezos.Core Tezos.Crypto @@ -119,12 +120,14 @@ Tezos.Crypto.Util Util.Alternative Util.ByteString + Util.CLI Util.Default Util.Exception Util.Fcf Util.Generic Util.Instances Util.IO + Util.Label Util.Lens Util.Markdown Util.Named @@ -133,6 +136,7 @@ Util.Test.Arbitrary Util.Test.Ingredients Util.Text + Util.TH Util.Type Util.Typeable Util.TypeLits @@ -145,7 +149,7 @@ hs-source-dirs: src default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0 + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude build-depends: HUnit , QuickCheck @@ -168,6 +172,7 @@ , gitrev , hex-text , hspec + , hspec-expectations , interpolate , lens , megaparsec >=7.0.0 @@ -175,6 +180,7 @@ , morley-prelude >=0.3.0 , mtl , named + , optparse-applicative , parser-combinators >=1.0.0 , quickcheck-arbitrary-adt , quickcheck-instances @@ -187,6 +193,7 @@ , tasty-quickcheck , template-haskell , text + , tezos-bake-monitor-lib , th-lift , th-lift-instances , time @@ -207,7 +214,7 @@ hs-source-dirs: app default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0 + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude build-depends: base-noprelude >=4.7 && <5 , fmt @@ -230,6 +237,7 @@ Test.Interpreter Test.Interpreter.Apply Test.Interpreter.Auction + Test.Interpreter.Balance Test.Interpreter.CallSelf Test.Interpreter.Compare Test.Interpreter.ComparePairs @@ -266,7 +274,7 @@ hs-source-dirs: test default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0 -threaded -with-rtsopts=-N + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -threaded -with-rtsopts=-N build-tool-depends: tasty-discover:tasty-discover build-depends: @@ -298,4 +306,22 @@ , tasty-quickcheck , text , unordered-containers + default-language: Haskell2010 + +benchmark morley-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_morley + hs-source-dirs: + bench + default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude + build-depends: + base-noprelude >=4.7 && <5 + , containers + , gauge + , megaparsec >=7.0.0 + , morley + , morley-prelude default-language: Haskell2010 diff --git a/src/Michelson/Doc.hs b/src/Michelson/Doc.hs --- a/src/Michelson/Doc.hs +++ b/src/Michelson/Doc.hs @@ -29,6 +29,7 @@ , docGroupContent , docDefinitionRef + , DGeneralInfoSection (..) , DName (..) , DDescription (..) , DGitRevision (..) @@ -36,6 +37,7 @@ , mkDGitRevision , morleyRepoSettings , DComment (..) + , DAnchor (..) ) where import qualified Data.Map as M @@ -167,7 +169,7 @@ manchor <> docItemToMarkdown l d <> "\n\n" where manchor = case docItemRef d of - DocItemRef (DocItemId docItemId) -> mdAnchor docItemId + DocItemRef docItemId -> mdAnchor docItemId DocItemNoRef -> "" -- | Order items by their 'docItemId'. @@ -184,13 +186,14 @@ :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) => Markdown -> d -> Markdown docDefinitionRef refText d = case docItemRef d of - DocItemRef (DocItemId docItemId) -> mdLocalRef refText docItemId + DocItemRef docItemId -> mdLocalRef refText docItemId -- | Some unique identifier of a doc item. -- -- All doc items which should be refer-able need to have this identifier. newtype DocItemId = DocItemId Text deriving stock (Eq, Ord, Show) + deriving newtype (ToAnchor) -- | Position of all doc items of some type. newtype DocItemPos = DocItemPos Natural @@ -220,6 +223,12 @@ data SomeDocItem where SomeDocItem :: DocItem d => d -> SomeDocItem +-- NFData instance is needed for benchmarks and we want to avoid requiring users +-- to implement NFData instance for every single DocItem and they should not +-- affect the performance anyway. +instance NFData SomeDocItem where + rnf (SomeDocItem _) = () + -- | Hides some documentation item which is put to "definitions" section. data SomeDocDefinitionItem where SomeDocDefinitionItem @@ -316,10 +325,13 @@ case sectionDesc of Nothing -> "" Just sd -> sd <> "\n\n" + resItems = docItemsOrder $ map deItem (toList items) content = - mconcat $ docItemsOrder (map deItem $ toList items) <&> \di -> + mconcat $ resItems <&> \di -> docItemToMarkdownFull (headerLevelDelta hl) di - in sectionNameFull <> sectionDescFull <> content + in if null resItems + then "" + else sectionNameFull <> sectionDescFull <> content -- | Lift a doc item to a block, be it atomic doc item or grouping one. docItemToBlockGeneral :: forall di. DocItem di => di -> Maybe SubDoc -> DocBlock @@ -447,11 +459,23 @@ -- Basic doc items ---------------------------------------------------------------------------- +-- | General (meta-)information about the contract such as git +-- revision, contract's authors, etc. Should be relatively short (not +-- several pages) because it is put somewhere close to the beginning of +-- documentation. +newtype DGeneralInfoSection = DGeneralInfoSection SubDoc + +instance DocItem DGeneralInfoSection where + type DocItemPosition DGeneralInfoSection = 1 + docItemSectionName = Nothing + docItemToMarkdown lvl (DGeneralInfoSection subDoc) = + subDocToMarkdown lvl subDoc + -- | Give a name to document block. data DName = DName Text SubDoc instance DocItem DName where - type DocItemPosition DName = 1 + type DocItemPosition DName = 3 docItemSectionName = Nothing docItemToMarkdown lvl (DName name doc) = mdHeader lvl (build name) <> @@ -522,10 +546,10 @@ value -> error $ "Unknown value returned by git: " <> show value instance DocItem DGitRevision where - type DocItemPosition DGitRevision = 7 + type DocItemPosition DGitRevision = 2 docItemSectionName = Nothing docItemToMarkdown _ (DGitRevisionKnown DGitRevisionInfo{..}) = - mconcat $ + mconcat [ mdSubsection "Code revision" $ let link = grsMkGitRevision dgrRepoSettings dgrCommitSha in mconcat @@ -536,7 +560,7 @@ ] docItemToMarkdown _ DGitRevisionUnknown = "" --- | Comment in the doc (mostly used for licenses) +-- | Comment in the doc (mostly used for licenses) data DComment = DComment Text instance DocItem DComment where @@ -544,3 +568,11 @@ docItemSectionName = Nothing docItemToMarkdown _ (DComment commentText) = "" + +-- | A hand-made anchor. +data DAnchor = DAnchor Anchor + +instance DocItem DAnchor where + type DocItemPosition DAnchor = 4 + docItemSectionName = Nothing + docItemToMarkdown _ (DAnchor a) = mdAnchor a diff --git a/src/Michelson/Doc/Test.hs b/src/Michelson/Doc/Test.hs --- a/src/Michelson/Doc/Test.hs +++ b/src/Michelson/Doc/Test.hs @@ -16,6 +16,7 @@ -- ** Individual test predicates , testContractNameAtTop + , testNoGitInfo , testDocNotEmpty , testNoAdjacentDescriptions @@ -24,6 +25,7 @@ , forEachContractDocItem ) where +import qualified Data.List as L import qualified Data.Text as T import Data.Text.Lazy.Builder (toLazyText) import Fmt (Buildable(..), blockListF, fmt, nameF, pretty) @@ -61,6 +63,9 @@ build DocTest{..} = "Doc test '" <> build dtDesc <> "'" -- | Construct 'DocTest'. +-- +-- Note: you should not declare helpers with this function rather use it +-- directly in every test suite. mkDocTest :: HasCallStack => String @@ -74,9 +79,16 @@ -- | Exclude given test suite. excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest] -excludeDocTest toExclude tests - | toExclude `elem` tests = filter (/= toExclude) tests - | otherwise = error $ "Not in the list of doc items: " <> pretty toExclude +excludeDocTest toExclude tests = + case L.partition (== toExclude) tests of + ([], _) -> + error $ "Not in the list of doc items: " <> pretty toExclude + (_ : _ : _, _) -> + -- This is possible if someone abused 'mkDocTest' and created a function + -- which calls it and this function is used to create multiple predicates + error "Running invalid doc predicates: multiple ones were considered equal" + ([_], notExcluded) -> + notExcluded -- | Calling @excludeDocTests tests toExclude@ returns all test suites from -- @tests@ which are not present in @toExclude@. @@ -136,10 +148,24 @@ testContractNameAtTop :: DocTest testContractNameAtTop = mkDocTest "The whole contract is wrapped into 'DName'" $ - \contractDoc -> - assertBool "There is no 'DName' at the top" . isJust $ - lookupDocBlockSection @DName (cdContents contractDoc) + \contractDoc -> do + let mSections = lookupDocBlockSection @DName (cdContents contractDoc) + case mSections of + Nothing -> assertFailure "There is no 'DName' at the top" + Just _ -> return () +-- | Check that contracts themselves do not set the git revision. It is supposed to be filled only +-- in the executable. +testNoGitInfo :: DocTest +testNoGitInfo = + mkDocTest "Git revision is not set in the contract" $ + \contractDoc -> do + assertions <- sequence $ forEachContractDocItem contractDoc $ \case + DGitRevisionUnknown -> return () + _ -> assertFailure "Unexpected Git revision" + assertBool "No Git revision placeholder found or more than one" $ + (length assertions == 1) + -- | Check that there is at least one non-grouping doc item. -- -- If there is no such, rendered documentation will be empty which signals about @@ -196,6 +222,7 @@ testDocBasic :: [DocTest] testDocBasic = [ testContractNameAtTop + , testNoGitInfo , testDocNotEmpty , testNoAdjacentDescriptions , testDescriptionsAreWellFormatted diff --git a/src/Michelson/ErrorPos.hs b/src/Michelson/ErrorPos.hs --- a/src/Michelson/ErrorPos.hs +++ b/src/Michelson/ErrorPos.hs @@ -8,14 +8,16 @@ , LetName (..) ) where +import qualified Data.Aeson as Aeson import Data.Data (Data(..)) +import Data.Default (Default(..)) import qualified Data.Text as T -import Data.Default (Default (..)) -import qualified Data.Aeson as Aeson newtype Pos = Pos Word deriving stock (Eq, Ord, Show, Generic, Data) +instance NFData Pos + mkPos :: Int -> Pos mkPos x | x < 0 = error $ "negative pos: " <> show x @@ -24,17 +26,23 @@ data SrcPos = SrcPos Pos Pos deriving stock (Eq, Ord, Show, Generic, Data) +instance NFData SrcPos + srcPos :: Word -> Word -> SrcPos srcPos x y = SrcPos (Pos x) (Pos y) newtype LetName = LetName T.Text deriving stock (Eq, Ord, Show, Data, Generic) +instance NFData LetName + type LetCallStack = [LetName] data InstrCallStack = InstrCallStack { icsCallStack :: LetCallStack , icsSrcPos :: SrcPos } deriving stock (Eq, Ord, Show, Generic, Data) + +instance NFData InstrCallStack instance Default Pos where def = Pos 0 diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs --- a/src/Michelson/Interpret.hs +++ b/src/Michelson/Interpret.hs @@ -6,27 +6,33 @@ , MichelsonFailed (..) , RemainingSteps (..) , SomeItStack (..) - , EvalOp , MorleyLogs (..) , noMorleyLogs , interpret , interpretInstr , ContractReturn - , handleContractReturn - + , mkInitStack + , fromFinalStack , interpretUntyped , InterpretError (..) , InterpretResult (..) + , EvalM + , InstrRunner , runInstr , runInstrNoGas , runUnpack + + -- * Internals + , initInterpreterState + , handleContractReturn + , runInstrImpl ) where import Prelude hiding (EQ, GT, LT) -import Control.Monad.Except (throwError) +import Control.Monad.Except (MonadError, throwError) import Data.Default (Default(..)) import qualified Data.Map as Map import qualified Data.Set as Set @@ -38,16 +44,17 @@ import Michelson.Interpret.Pack (packValue') import Michelson.Interpret.Unpack (UnpackError, unpackValue') import Michelson.TypeCheck - (SomeContract(..), SomeNotedValue(..), TCError, TCTypeError(..), TcOriginatedContracts, eqType, - matchTypes, runTypeCheck, typeCheckContract, typeCheckValue) + (SomeContract(..), TCError, TcOriginatedContracts, matchTypes, runTypeCheck, + typeCheckContract, typeCheckValue) import Michelson.Typed import qualified Michelson.Typed as T -import Michelson.Typed.Convert (convertContract, untypeValue) +import Michelson.Typed.Convert (convertContractCode, untypeValue) import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512) import Util.Peano (LongerThan, Peano, Sing(SS, SZ)) +import Util.TH import Util.Type import Util.Typeable @@ -122,8 +129,6 @@ | IllTypedContract TCError | IllTypedParam TCError | IllTypedStorage TCError - | UnexpectedParamType TCTypeError - | UnexpectedStorageType TCTypeError deriving stock (Generic) deriving stock instance Show InterpretError @@ -153,12 +158,15 @@ , iurNewState = st } --- | Morley interpreter state +-- | Morley logs for interpreter state. newtype MorleyLogs = MorleyLogs { unMorleyLogs :: [Text] - } deriving stock (Eq, Show) + -- ^ Logs in reverse order. + } deriving stock (Eq, Show, Generic) deriving newtype (Default, Buildable) +instance NFData MorleyLogs + noMorleyLogs :: MorleyLogs noMorleyLogs = MorleyLogs [] @@ -172,20 +180,19 @@ -> ContractEnv -> Either InterpretError InterpretResult interpretUntyped uContract@U.Contract{..} paramU initStU env = do - SomeContract (FullContract (instr :: Contract cp st) _ _) + SomeContract (FullContract (instr :: ContractCode cp st) _ _) <- first IllTypedContract $ typeCheckContract (ceContracts env) uContract - withUType para $ \(sgp, ntp) -> - withUType stor $ \(sgs, nts) -> do - paramV :::: ((_ :: Sing cp1), _) - <- first IllTypedParam $ runTypeCheck para (ceContracts env) $ usingReaderT def $ - typeCheckValue paramU (sgp, ntp) - initStV :::: ((_ :: Sing st1), _) - <- first IllTypedStorage $ runTypeCheck para (ceContracts env) $ usingReaderT def $ - typeCheckValue initStU (sgs, nts) - Refl <- first UnexpectedStorageType $ eqType @st @st1 - Refl <- first UnexpectedParamType $ eqType @cp @cp1 - handleContractReturn $ - interpret instr epcCallRootUnsafe paramV initStV env + -- Do creates dummy scope to somehow overcome this: + -- GHC internal error: ‘st’ is not in scope during type checking, but it passed the renamer. + do + paramV + <- first IllTypedParam $ runTypeCheck para (ceContracts env) $ usingReaderT def $ + typeCheckValue @cp paramU + initStV + <- first IllTypedStorage $ runTypeCheck para (ceContracts env) $ usingReaderT def $ + typeCheckValue @st initStU + handleContractReturn $ + interpret instr epcCallRootUnsafe paramV initStV env type ContractReturn st = (Either MichelsonFailed ([Operation], T.Value st), InterpreterState) @@ -194,43 +201,43 @@ :: (StorageScope st) => ContractReturn st -> Either InterpretError InterpretResult handleContractReturn (ei, s) = - bimap RuntimeFailure constructIR $ - bimap (,isMorleyLogs s) (,s) ei + bimap (RuntimeFailure . (, isMorleyLogs s)) (constructIR . (, s)) ei interpret' :: forall cp st arg. - Contract cp st + ContractCode cp st -> EntryPointCallT cp arg -> T.Value arg -> T.Value st -> ContractEnv -> InterpreterState -> ContractReturn st -interpret' instr epc param initSt env ist = first (fmap toRes) $ +interpret' instr epc param initSt env ist = first (fmap fromFinalStack) $ runEvalOp - (runInstr instr (T.VPair (liftParam param, initSt) :& RNil)) + (runInstr instr $ mkInitStack (liftCallArg epc param) initSt) env ist - where - liftParam :: T.Value arg -> T.Value cp - liftParam = compileEpLiftSequence (epcLiftSequence epc) - toRes - :: (Rec (T.Value' instr) '[ 'TPair ('TList 'TOperation) st ]) - -> ([T.Operation' instr], T.Value' instr st) - toRes (T.VPair (T.VList ops_, newSt) :& RNil) = - (map (\(T.VOp op) -> op) ops_, newSt) +mkInitStack :: T.Value param -> T.Value st -> Rec T.Value (ContractInp param st) +mkInitStack param st = T.VPair (param, st) :& RNil +fromFinalStack :: Rec T.Value (ContractOut st) -> ([T.Operation], T.Value st) +fromFinalStack (T.VPair (T.VList ops, st) :& RNil) = + (map (\(T.VOp op) -> op) ops, st) + interpret - :: Contract cp st + :: ContractCode cp st -> EntryPointCallT cp arg -> T.Value arg -> T.Value st -> ContractEnv -> ContractReturn st interpret instr epc param initSt env = - interpret' instr epc param initSt env (InterpreterState def $ ceMaxSteps env) + interpret' instr epc param initSt env (initInterpreterState env) +initInterpreterState :: ContractEnv -> InterpreterState +initInterpreterState env = InterpreterState def (ceMaxSteps env) + -- | Interpret an instruction in vacuum, putting no extra contraints on -- its execution. -- @@ -251,32 +258,45 @@ SomeItStack :: T.ExtInstr inp -> Rec T.Value inp -> SomeItStack newtype RemainingSteps = RemainingSteps Word64 - deriving stock (Show) + deriving stock (Show, Generic) deriving newtype (Eq, Ord, Buildable, Num) +instance NFData RemainingSteps + data InterpreterState = InterpreterState { isMorleyLogs :: MorleyLogs , isRemainingSteps :: RemainingSteps - } deriving stock (Show) + } deriving stock (Show, Generic) +instance NFData InterpreterState + type EvalOp a = ExceptT MichelsonFailed (ReaderT ContractEnv (State InterpreterState)) a -runEvalOp :: - EvalOp a +runEvalOp + :: EvalOp a -> ContractEnv -> InterpreterState -> (Either MichelsonFailed a, InterpreterState) runEvalOp act env initSt = flip runState initSt $ usingReaderT env $ runExceptT act --- | Function to change amount of remaining steps stored in State monad -runInstr - :: Instr inp out +type EvalM m = + ( MonadReader ContractEnv m + , MonadState InterpreterState m + , MonadError MichelsonFailed m + ) + +type InstrRunner m = + forall inp out. + Instr inp out -> Rec (T.Value) inp - -> EvalOp (Rec (T.Value) out) + -> m (Rec (T.Value) out) + +-- | Function to change amount of remaining steps stored in State monad +runInstr :: EvalM m => InstrRunner m runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@(InstrWithNotes _ _i1) r = runInstrImpl runInstr i r runInstr i@(InstrWithVarNotes _ _i1) r = runInstrImpl runInstr i r @@ -290,23 +310,11 @@ modify (\s -> s {isRemainingSteps = rs - 1}) runInstrImpl runInstr i r -runInstrNoGas - :: forall a b . T.Instr a b -> Rec T.Value a -> EvalOp (Rec T.Value b) +runInstrNoGas :: EvalM m => InstrRunner m runInstrNoGas = runInstrImpl runInstrNoGas - -- | Function to interpret Michelson instruction(s) against given stack. -runInstrImpl - :: (forall inp1 out1 . - Instr inp1 out1 - -> Rec (T.Value) inp1 - -> EvalOp (Rec T.Value out1) - ) -> - (forall inp out . - Instr inp out - -> Rec (T.Value) inp - -> EvalOp (Rec T.Value out) - ) +runInstrImpl :: EvalM m => InstrRunner m -> InstrRunner m runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' runInstrImpl runner (InstrWithNotes _ i) r = runner i r runInstrImpl runner (InstrWithVarNotes _ i) r = runner i r @@ -375,12 +383,13 @@ runInstrImpl runner (MAP ops) (a :& r) = case ops of (code :: Instr (MapOpInp c ': s) (b ': s)) -> do - newList <- mapM (\(val :: T.Value (MapOpInp c)) -> do - res <- runner code (val :& r) + -- Evaluation must preserve all stack modifications that @MAP@'s does. + (newStack, newList) <- foldlM (\(curStack, curList) (val :: T.Value (MapOpInp c)) -> do + res <- runner code (val :& curStack) case res of - ((newVal :: T.Value b) :& _) -> pure newVal) - $ mapOpToList @c a - pure $ mapOpFromList a newList :& r + ((nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList)) + (r, []) (mapOpToList @c a) + pure $ mapOpFromList a (reverse newList) :& newStack runInstrImpl runner (ITER ops) (a :& r) = case ops of (code :: Instr (IterOpEl c ': s) s) -> @@ -475,9 +484,9 @@ case Map.lookup ca ceContracts of -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has -- valid parameter type. Should be not necessary after [#36]. - Just tc@(AsUType tcSing (ParamNotesUnsafe -> tcNotes)) -> + Just tc@(AsUTypeExt tcSing (ParamNotesUnsafe -> tcNotes)) -> case (T.checkOpPresence tcSing, T.checkNestedBigMapsPresence tcSing) of - (OpAbsent, NestedBigMapsAbsent) -> castContract addr epName (tcSing, tcNotes) :& r + (OpAbsent, NestedBigMapsAbsent) -> castContract addr epName tcNotes :& r _ -> error $ "Illegal type in parameter of env contract: " <> pretty tc -- TODO [#36]: we can do this safely once 'TcOriginatedContracts' stores -- typed stuff. @@ -485,7 +494,7 @@ where castContract :: forall p. T.ParameterScope p - => Address -> EpName -> (Sing p, T.ParamNotes p) -> T.Value ('TOption ('TContract a)) + => Address -> 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 na epc <- T.mkEntryPointCall epName param @@ -542,11 +551,11 @@ -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp - :: (ArithOp aop n m, Typeable n, Typeable m) + :: (ArithOp aop n m, Typeable n, Typeable m, EvalM monad) => proxy aop -> CValue n -> CValue m - -> EvalOp (T.Value' instr ('Tc (ArithRes aop n m))) + -> monad (T.Value' instr ('Tc (ArithRes aop n m))) runArithOp op l r = case evalOp op l r of Left err -> throwError (MichelsonArithError err) Right res -> pure (T.VC res) @@ -567,7 +576,7 @@ => Address -> Maybe (T.Value ('Tc 'U.CKeyHash)) -> Mutez - -> Contract param store + -> ContractCode param store -> Value' Instr store -> U.OriginationOperation createOrigOp originator mbDelegate bal contract g = @@ -576,13 +585,13 @@ , ooDelegate = unwrapMbKeyHash mbDelegate , ooBalance = bal , ooStorage = untypeValue g - , ooContract = convertContract contract + , ooContract = convertContractCode contract } unwrapMbKeyHash :: Maybe (T.Value ('Tc 'U.CKeyHash)) -> Maybe KeyHash unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(T.VC (CvKeyHash keyHash)) -> keyHash -interpretExt :: SomeItStack -> EvalOp () +interpretExt :: EvalM m => SomeItStack -> m () interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do let getEl (Left l) = l getEl (Right str) = withStackElem str st show @@ -613,3 +622,5 @@ loop = \case (e :& _, SZ) -> cont e (_ :& es, SS n) -> loop (es, n) + +$(deriveGADTNFData ''MichelsonFailed) diff --git a/src/Michelson/Interpret/Pack.hs b/src/Michelson/Interpret/Pack.hs --- a/src/Michelson/Interpret/Pack.hs +++ b/src/Michelson/Interpret/Pack.hs @@ -26,7 +26,7 @@ import Michelson.Text import Michelson.Typed import Michelson.Untyped.Annotation - (Annotation(..), FieldAnn, TypeAnn, VarAnn, noAnn, renderWEAnn) + (Annotation(..), FieldAnn, TypeAnn, VarAnn, fullAnnSet, isNoAnnSet, noAnn) import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds) import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes) @@ -52,9 +52,6 @@ packCode' :: Instr inp out -> ByteString packCode' = LBS.toStrict . encodeInstrs -surround :: LByteString -> LByteString -> ByteString -> LByteString -surround prefix suffix main = prefix <> LBS.fromStrict main <> suffix - -- | Generic serializer. -- -- We don't require @HasNoBigMap@ constraint here since the big_map serialization @@ -143,8 +140,10 @@ encodeAddress :: Address -> LByteString encodeAddress = \case - KeyAddress keyHash -> "\x00" <> (encodeKeyHashRaw keyHash) - ContractAddress (ContractHash address) -> surround "\x01" "\x00" address + KeyAddress keyHash -> + "\x00" <> (encodeKeyHashRaw keyHash) + ContractAddress (ContractHash address) -> + "\x01" <> LBS.fromStrict address <> "\x00" encodeEpAddress :: EpAddress -> LByteString encodeEpAddress (EpAddress addr epName) = @@ -393,15 +392,11 @@ encodeWithAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> LByteString -> LByteString encodeWithAnns tns fns vns encodedInput | null encodedInput = encodedInput - | null annsList = encodedInput + | isNoAnnSet annSet = encodedInput | otherwise = inputIncrem <> encodedAnns where - trimEndNoAnn a lst = if null lst && a == noAnn then [] else a : lst - tnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] tns - fnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] fns - vnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] vns - annsList = tnsText <> fnsText <> vnsText - encodedAnns = encodeAsList . encodeUtf8 $ unwords annsList + annSet = fullAnnSet tns fns vns + encodedAnns = encodeAsList . encodeUtf8 $ show @Text annSet inputIncrem = (1 + LBS.head encodedInput) `LBS.cons` LBS.tail encodedInput -- | Encode an instruction with variable annotations @@ -413,7 +408,7 @@ -- | Encode an instruction with Annotations encodeNotedInstr :: forall inp out. Instr inp out -> PackedNotes out -> [VarAnn] -> LByteString -encodeNotedInstr a (PackedNotes n _) vns = case (a, Proxy @out, n) of +encodeNotedInstr a (PackedNotes n) vns = case (a, Proxy @out, n) of (SOME, _, NTOption tn _ns) -> encodeWithAnns [tn] [] vns $ encodeInstr a (NONE, _ :: Proxy ('TOption t ': s), NTOption tn ns) -> diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs --- a/src/Michelson/Interpret/Unpack.hs +++ b/src/Michelson/Interpret/Unpack.hs @@ -480,7 +480,7 @@ -> m (RemFail T.Instr '[inp] '[out]) decodeTypeCheckLam uinstr = either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do - let inp = (sing @inp, starNotes, noAnn) ::& SNil + let inp = (starNotes, noAnn) ::& SNil _ :/ instr' <- typeCheckList uinstr inp case instr' of instr ::: out' -> diff --git a/src/Michelson/Macro.hs b/src/Michelson/Macro.hs --- a/src/Michelson/Macro.hs +++ b/src/Michelson/Macro.hs @@ -54,11 +54,15 @@ instance Buildable LetMacro where build = genericF +instance NFData LetMacro + data PairStruct = F (VarAnn, FieldAnn) | P PairStruct PairStruct deriving stock (Eq, Show, Data, Generic) +instance NFData PairStruct + instance Buildable PairStruct where build = genericF @@ -67,6 +71,8 @@ | D deriving stock (Eq, Show, Data, Generic) +instance NFData CadrStruct + instance Buildable CadrStruct where build = genericF @@ -90,6 +96,8 @@ LMac letMacro _ -> "" Seq parsedOps _ -> "" +instance NFData ParsedOp + ------------------------------------- -- Types produced by parser ------------------------------------- @@ -160,6 +168,8 @@ ASSERT_RIGHT -> "ASSERT_RIGHT" IF_SOME parsedOps1 parsedOps2 -> "" IF_RIGHT parsedOps1 parsedOps2 -> "" + +instance NFData Macro expandList :: [ParsedOp] -> [ExpandedOp] expandList = fmap (expand []) diff --git a/src/Michelson/OpSize.hs b/src/Michelson/OpSize.hs --- a/src/Michelson/OpSize.hs +++ b/src/Michelson/OpSize.hs @@ -77,7 +77,7 @@ EMPTY_MAP ta va ct t -> annsOpSize ta va <> comparableOpSize ct <> typeOpSize t EMPTY_BIG_MAP ta va ct t -> annsOpSize ta va <> comparableOpSize ct <> typeOpSize t MAP va is -> annsOpSize va <> subcodeOpSize is - ITER is -> annsOpSize <> subcodeOpSize is + ITER is -> subcodeOpSize is MEM va -> annsOpSize va GET va -> annsOpSize va UPDATE va -> annsOpSize va @@ -216,26 +216,28 @@ ctOpSize :: CT -> OpSize ctOpSize _ = OpSize 2 --- | Accepts arbitrary number of 'Annotation's (maybe of different types) --- which belong to the same entity and returns their total operation size. +-- | Accepts an arbitrary number of 'TypeAnn' 'FieldAnn' and/or 'VarAnn' that +-- belong to the same entity and returns their total operation size. -- -- Note that annotations which belong to the same entity (type or instruction) --- __must be__ considered in aggregate using one call of this function. +-- __must be__ considered in aggregate using one call of this function and to be +-- specified in order. See 'AnnotationSet' for details. annsOpSize :: AnnsOpSizeVararg x => x -annsOpSize = annsOpSizeVararg [] +annsOpSize = annsOpSizeVararg emptyAnnSet class AnnsOpSizeVararg x where - annsOpSizeVararg :: [SomeAnn] -> x + annsOpSizeVararg :: AnnotationSet -> x -instance AnnsOpSizeVararg x => AnnsOpSizeVararg (Annotation t -> x) where - annsOpSizeVararg acc an = annsOpSizeVararg (convAnn an : acc) -instance AnnsOpSizeVararg x => AnnsOpSizeVararg ([Annotation t] -> x) where - annsOpSizeVararg acc an = annsOpSizeVararg (map convAnn an <> acc) +instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg (Annotation t -> x) where + annsOpSizeVararg acc an = annsOpSizeVararg (acc <> singleAnnSet an) +instance (KnownAnnTag t, AnnsOpSizeVararg x) => AnnsOpSizeVararg ([Annotation t] -> x) where + annsOpSizeVararg acc ans = annsOpSizeVararg (acc <> singleGroupAnnSet ans) + instance AnnsOpSizeVararg OpSize where annsOpSizeVararg = annsOpSizeImpl -annsOpSizeImpl :: [SomeAnn] -> OpSize -annsOpSizeImpl anns = case filter (/= noAnn) anns of - [] -> mempty - as -> OpSize . fromIntegral $ 3 * (length as + 1) +annsOpSizeImpl :: AnnotationSet -> OpSize +annsOpSizeImpl annSet + | isNoAnnSet annSet = mempty + | otherwise = OpSize . fromIntegral $ 3 * (minAnnSetSize annSet + 1) diff --git a/src/Michelson/Optimizer.hs b/src/Michelson/Optimizer.hs --- a/src/Michelson/Optimizer.hs +++ b/src/Michelson/Optimizer.hs @@ -21,12 +21,14 @@ import Prelude hiding (EQ) import Data.Default (Default(def)) +import Data.Singletons (sing) import Michelson.Interpret.Pack (packValue') import Michelson.Typed.Aliases (Value) import Michelson.Typed.CValue import Michelson.Typed.Instr import Michelson.Typed.Scope (PackedValScope) +import Michelson.Typed.Sing import Michelson.Typed.T import Michelson.Typed.Util (DfsSettings(..), dfsInstr) import Michelson.Typed.Value @@ -89,6 +91,9 @@ `orSimpleRule` simpleDrops `orSimpleRule` internalNop `orSimpleRule` simpleDips + `orSimpleRule` adjacentDips + `orSimpleRule` specificPush + `orSimpleRule` pairUnpair -- | We do not enable 'pushPack' rule by default because it is -- potentially dangerous. @@ -129,10 +134,19 @@ Seq (PUSH _) (Seq DROP c) -> Just c Seq DUP (Seq DROP c) -> Just c Seq UNIT (Seq DROP c) -> Just c + Seq NOW (Seq DROP c) -> Just c + Seq SENDER (Seq DROP c) -> Just c + Seq EMPTY_MAP (Seq DROP c) -> Just c + Seq EMPTY_SET (Seq DROP c) -> Just c + Seq SWAP SWAP -> Just Nop Seq (PUSH _) DROP -> Just Nop Seq DUP DROP -> Just Nop Seq UNIT DROP -> Just Nop + Seq NOW DROP -> Just Nop + Seq SENDER DROP -> Just Nop + Seq EMPTY_MAP DROP -> Just Nop + Seq EMPTY_SET DROP -> Just Nop _ -> Nothing dupSwap2dup :: Rule @@ -149,6 +163,14 @@ Seq (PUSH x) (DIP f) -> Just (Seq f (PUSH x)) Seq UNIT (Seq (DIP f) c) -> Just (Seq f (Seq UNIT c)) Seq UNIT (DIP f) -> Just (Seq f UNIT) + Seq NOW (Seq (DIP f) c) -> Just (Seq f (Seq NOW c)) + Seq NOW (DIP f) -> Just (Seq f NOW) + Seq SENDER (Seq (DIP f) c) -> Just (Seq f (Seq SENDER c)) + Seq SENDER (DIP f) -> Just (Seq f SENDER) + Seq EMPTY_MAP (Seq (DIP f) c) -> Just (Seq f (Seq EMPTY_MAP c)) + Seq EMPTY_MAP (DIP f) -> Just (Seq f EMPTY_MAP) + Seq EMPTY_SET (Seq (DIP f) c) -> Just (Seq f (Seq EMPTY_SET c)) + Seq EMPTY_SET (DIP f) -> Just (Seq 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 @@ -233,6 +255,48 @@ -- @gromak: same situation as with `DROP 1` (see above). -- Seq (DIPN (SS SZ) i) c -> Just (Seq (DIP i) c) -- DIPN (SS SZ) i -> Just (DIP i) + + _ -> Nothing + +adjacentDips :: Rule +adjacentDips = \case + Seq (DIP f) (DIP g) -> Just (DIP (Seq f g)) + + _ -> Nothing + +specificPush :: Rule +specificPush = \case + push@PUSH{} -> optimizePush push + Seq (push@PUSH{}) c -> (`Seq` c) <$> optimizePush push + + _ -> Nothing + where + optimizePush :: Instr inp out -> Maybe (Instr inp out) + optimizePush = \case + PUSH v | _ :: Value v <- v -> case v of + VUnit -> Just UNIT + VMap m + | null m -> case sing @v of STMap{} -> Just EMPTY_MAP + VSet m + | null m -> case sing @v of STSet{} -> Just EMPTY_SET + _ -> Nothing + + _ -> Nothing + +-- UNPAIR with continuation +pattern UNPAIR_c + :: () + => (i ~ ('TPair a b : s), i' ~ (a : b : s), o' ~ o) + => Instr i' o' -> Instr i o +pattern UNPAIR_c c = Seq DUP (Seq CAR (Seq (DIP CDR) c)) + +pairUnpair :: Rule +pairUnpair = \case + Seq PAIR (UNPAIR_c c) -> Just c + Seq PAIR UNPAIR -> Just Nop + + UNPAIR_c (Seq PAIR c) -> Just c + UNPAIR_c PAIR -> Just Nop _ -> Nothing diff --git a/src/Michelson/Parser.hs b/src/Michelson/Parser.hs --- a/src/Michelson/Parser.hs +++ b/src/Michelson/Parser.hs @@ -199,6 +199,7 @@ primOrMac = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX) <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp)) <|> (try (primWithPos pairOp) <|> macWithPos pairMac) + <|> (try (macWithPos duupMac) <|> try (macWithPos dupNMac) <|> primWithPos dupOp) ------------------------------------------------------------------------------- -- Safe construction of Haskell values diff --git a/src/Michelson/Parser/Error.hs b/src/Michelson/Parser/Error.hs --- a/src/Michelson/Parser/Error.hs +++ b/src/Michelson/Parser/Error.hs @@ -24,8 +24,10 @@ | WrongAccessArgs Natural Positive | WrongSetArgs Natural Positive | ExcessFieldAnnotation - deriving stock (Eq, Data, Ord, Show) + deriving stock (Eq, Data, Ord, Show, Generic) +instance NFData CustomParserException + instance ShowErrorComponent CustomParserException where showErrorComponent UnknownTypeException = "unknown type" showErrorComponent (StringLiteralException e) = showErrorComponent e @@ -44,7 +46,9 @@ data StringLiteralParserException = InvalidEscapeSequence Char | InvalidChar Char - deriving stock (Eq, Data, Ord, Show) + deriving stock (Eq, Data, Ord, Show, Generic) + +instance NFData StringLiteralParserException instance ShowErrorComponent StringLiteralParserException where showErrorComponent (InvalidEscapeSequence c) = diff --git a/src/Michelson/Parser/Instr.hs b/src/Michelson/Parser/Instr.hs --- a/src/Michelson/Parser/Instr.hs +++ b/src/Michelson/Parser/Instr.hs @@ -7,6 +7,7 @@ , mapOp , pairOp , cmpOp + , dupOp ) where import Prelude hiding (EQ, GT, LT, many, note, some, try) @@ -26,7 +27,7 @@ -- | Parser for primitive Michelson instruction (no macros and extensions). primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr primInstr contractParser opParser = choice - [ dropOp, dupOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp + [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp , ifNoneOp opParser, carOp, cdrOp, leftOp, rightOp, ifLeftOp opParser, nilOp , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser , memOp, getOp, updateOp, loopLOp opParser, loopOp opParser @@ -42,7 +43,7 @@ -- | Parse a sequence of instructions. ops' :: Parser ParsedOp -> Parser [ParsedOp] -ops' opParser = (braces $ sepEndBy opParser semicolon) <|> (pure <$> opParser) +ops' opParser = (braces $ sepEndBy opParser (optional semicolon)) <|> (pure <$> opParser) -- Control Structures diff --git a/src/Michelson/Parser/Macro.hs b/src/Michelson/Parser/Macro.hs --- a/src/Michelson/Parser/Macro.hs +++ b/src/Michelson/Parser/Macro.hs @@ -3,6 +3,8 @@ module Michelson.Parser.Macro ( macro -- * These are handled separately to have better error messages + , dupNMac + , duupMac , pairMac , ifCmpMac , mapCadrMac @@ -47,13 +49,20 @@ <|> word' "ASSERT_" ASSERTX <*> cmpOp <|> word' "ASSERT" ASSERT <|> do string' "DI"; n <- num "I"; symbol' "P"; DIIP (n + 1) <$> ops - <|> do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef <|> unpairMac <|> cadrMac <|> setCadrMac where ops = ops' opParser num str = fromIntegral . length <$> some (string' str) + +dupNMac :: Parser Macro +dupNMac = do symbol' "DUP"; DUUP <$> lexeme decimal <*> noteDef + +duupMac :: Parser Macro +duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef + where + num str = fromIntegral . length <$> some (string' str) pairMac :: Parser Macro pairMac = do diff --git a/src/Michelson/Parser/Types.hs b/src/Michelson/Parser/Types.hs --- a/src/Michelson/Parser/Types.hs +++ b/src/Michelson/Parser/Types.hs @@ -10,9 +10,9 @@ import qualified Data.Map as Map import Text.Megaparsec (Parsec) -import Michelson.Parser.Error import Michelson.Let (LetType, LetValue) import Michelson.Macro (LetMacro) +import Michelson.Parser.Error type Parser = ReaderT LetEnv (Parsec CustomParserException Text) diff --git a/src/Michelson/Printer.hs b/src/Michelson/Printer.hs --- a/src/Michelson/Printer.hs +++ b/src/Michelson/Printer.hs @@ -2,7 +2,7 @@ ( RenderDoc(..) , printDoc , printUntypedContract - , printTypedContract + , printTypedContractCode , printTypedFullContract , printSomeContract , printTypedValue @@ -24,9 +24,9 @@ -- | Convert a typed contract into a textual representation which -- will be accepted by the OCaml reference client. -printTypedContract :: (SingI p, SingI s) => Bool -> T.Contract p s -> TL.Text -printTypedContract forceSingleLine = - printUntypedContract forceSingleLine . T.convertContract +printTypedContractCode :: (SingI p, SingI s) => Bool -> T.ContractCode p s -> TL.Text +printTypedContractCode forceSingleLine = + printUntypedContract forceSingleLine . T.convertContractCode printTypedFullContract :: Bool -> T.FullContract p s -> TL.Text printTypedFullContract forceSingleLine fc@T.FullContract{} = diff --git a/src/Michelson/Printer/Util.hs b/src/Michelson/Printer/Util.hs --- a/src/Michelson/Printer/Util.hs +++ b/src/Michelson/Printer/Util.hs @@ -3,6 +3,7 @@ , Prettier(..) , printDoc , printDocB + , printDocS , renderOps , renderOpsList , spaces @@ -61,6 +62,10 @@ -- | Convert 'Doc' to 'Builder' in the same maner as 'printDoc'. printDocB :: Bool -> Doc -> Builder printDocB oneLine = displayB . doRender oneLine + +-- | Convert 'Doc' to 'String' in the same maner as 'printDoc'. +printDocS :: Bool -> Doc -> String +printDocS oneLine = toString . printDoc oneLine -- | Generic way to render the different op types that get passed -- to a contract. diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs --- a/src/Michelson/Runtime.hs +++ b/src/Michelson/Runtime.hs @@ -33,7 +33,6 @@ import Control.Lens (at, makeLenses, (%=)) import Control.Monad.Except (Except, runExcept, throwError) -import Data.Singletons (sing) import Data.Text.IO (getContents) import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+)) import Named ((:!), (:?), arg, argDef, defaults, (!)) @@ -49,8 +48,8 @@ import Michelson.TypeCheck (SomeContract, TCError, typeCheckContract, typeCheckTopLevelType, typeVerifyTopLevelType) import Michelson.Typed - (CreateContract(..), EpName, Operation'(..), SomeValue'(..), TransferTokens(..), convertContract, - untypeValue) + (CreateContract(..), EpName, Operation'(..), SomeValue'(..), TransferTokens(..), + convertContractCode, untypeValue) import qualified Michelson.Typed as T import Michelson.Untyped (Contract, OriginationOperation(..), mkContractAddress) import qualified Michelson.Untyped as U @@ -445,10 +444,13 @@ (Just (ASContract cs), _) -> do let existingContracts = extractAllContracts gs + -- can't overflow if global state is correct (because we can't + -- create money out of nowhere) + newBalance = csBalance cs `unsafeAddMutez` tdAmount txData contractEnv = ContractEnv { ceNow = now , ceMaxSteps = remainingSteps - , ceBalance = csBalance cs + , ceBalance = newBalance , ceContracts = existingContracts , ceSelf = addr , ceSource = sourceAddr @@ -461,7 +463,7 @@ SomeContractAndStorage typedContract typedStorage <- getTypedContractAndStorage EEIllTypedContract EEIllTypedStorage gs cs T.MkEntryPointCallRes _ epc - <- T.mkEntryPointCall epName (sing, T.fcParamNotesSafe typedContract) + <- T.mkEntryPointCall epName (T.fcParamNotesSafe typedContract) & maybe (throwError $ EEUnknownEntrypoint epName) pure typedParameter <- first EEIllTypedParameter $ typeVerifyTopLevelType existingContracts (tdParameter txData) @@ -476,9 +478,6 @@ typedParameter typedStorage contractEnv let newValueU = untypeValue newValue - -- can't overflow if global state is correct (because we can't - -- create money out of nowhere) - newBalance = csBalance cs `unsafeAddMutez` tdAmount txData updBalance | newBalance == csBalance cs = Nothing | otherwise = Just $ GSSetBalance addr newBalance @@ -545,6 +544,6 @@ , ooDelegate = ccDelegate cc , ooBalance = ccBalance cc , ooStorage = untypeValue (ccStorageVal cc) - , ooContract = convertContract (ccContractCode cc) + , ooContract = convertContractCode (ccContractCode cc) } in Just (OriginateOp origination) diff --git a/src/Michelson/Test.hs b/src/Michelson/Test.hs --- a/src/Michelson/Test.hs +++ b/src/Michelson/Test.hs @@ -19,7 +19,9 @@ , ContractPropValidator , contractProp , contractPropVal + , validateSuccess , validateStorageIs + , validateMichelsonFailsWith -- * Integrational testing -- ** Testing engine diff --git a/src/Michelson/Test/Import.hs b/src/Michelson/Test/Import.hs --- a/src/Michelson/Test/Import.hs +++ b/src/Michelson/Test/Import.hs @@ -32,7 +32,7 @@ import Michelson.Parser.Error (ParserException(..)) import Michelson.Runtime (parseExpandContract, prepareContract) import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract) -import Michelson.Typed (Contract, FullContract(..), toUType) +import Michelson.Typed (FullContract(..), toUType) import qualified Michelson.Untyped as U import Util.IO @@ -48,7 +48,7 @@ -- result will notify about problem). testTreesWithContract :: (Each [Typeable, SingI] [cp, st], HasCallStack) - => FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree] + => FilePath -> ((U.Contract, FullContract cp st) -> IO [TestTree]) -> IO [TestTree] testTreesWithContract = testTreesWithContractImpl importContract -- | Like 'testTreesWithContract' but supplies only untyped contract. @@ -61,7 +61,7 @@ -- | Like 'testTreesWithContract' but supplies only typed contract. testTreesWithTypedContract :: (Each [Typeable, SingI] [cp, st], HasCallStack) - => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree] + => FilePath -> (FullContract cp st -> IO [TestTree]) -> IO [TestTree] testTreesWithTypedContract = testTreesWithContractImpl (fmap snd . importContract) @@ -94,14 +94,14 @@ -- result will notify about problem). specWithContract :: (Each [Typeable, SingI] [cp, st], HasCallStack) - => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec + => FilePath -> ((U.Contract, FullContract cp st) -> Spec) -> Spec specWithContract = specWithContractImpl importContract -- | A version of 'specWithContract' which passes only the typed -- representation of the contract. specWithTypedContract :: (Each [Typeable, SingI] [cp, st], HasCallStack) - => FilePath -> (Contract cp st -> Spec) -> Spec + => FilePath -> (FullContract cp st -> Spec) -> Spec specWithTypedContract = specWithContractImpl (fmap snd . importContract) specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec @@ -137,13 +137,13 @@ Each [Typeable, SingI] [cp, st] => FilePath -> Text - -> Either ImportContractError (U.Contract, Contract cp st) + -> Either ImportContractError (U.Contract, FullContract cp st) readContract filePath txt = do contract <- first ICEParse $ parseExpandContract (Just filePath) txt - SomeContract (FullContract (instr :: Contract cp' st') _ _) + SomeContract (tContract@FullContract{} :: FullContract cp' st') <- first ICETypeCheck $ typeCheckContract mempty contract case (eqT @cp @cp', eqT @st @st') of - (Just Refl, Just Refl) -> pure (contract, instr) + (Just Refl, Just Refl) -> pure (contract, tContract) (Nothing, _) -> Left $ ICEUnexpectedParamType (U.para contract) (toUType $ demote @cp) _ -> Left (ICEUnexpectedStorageType (U.stor contract) (toUType $ demote @st)) @@ -158,7 +158,7 @@ importContract :: forall cp st . Each [Typeable, SingI] [cp, st] - => FilePath -> IO (U.Contract, Contract cp st) + => FilePath -> IO (U.Contract, FullContract cp st) importContract file = either throwM pure =<< readContract file <$> readFileUtf8 file importUntypedContract :: FilePath -> IO U.Contract diff --git a/src/Michelson/Test/Unit.hs b/src/Michelson/Test/Unit.hs --- a/src/Michelson/Test/Unit.hs +++ b/src/Michelson/Test/Unit.hs @@ -7,19 +7,24 @@ , contractPropVal , contractHasEntryPoints , matchContractEntryPoints + , mkEntrypointsMap , hasEp + , validateSuccess , validateStorageIs + , validateMichelsonFailsWith ) where import Data.List.NonEmpty (fromList) import qualified Data.Map as Map +import Data.Singletons (SingI) import Fmt ((+|), (|+)) +import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy) import Test.HUnit (Assertion, assertFailure, (@?=)) -import Michelson.Interpret (ContractEnv, ContractReturn, interpret) +import Michelson.Interpret (ContractEnv, ContractReturn, MichelsonFailed(..), interpret) import Michelson.Printer (printUntypedContract) import Michelson.Runtime (parseExpandContract) -import Michelson.Typed (Contract, IsoValue(..), ToT, epNameToParamAnn) +import Michelson.Typed (FullContract, IsoValue(..), ToT, epNameToParamAnn) import qualified Michelson.Typed as T import Michelson.Untyped (EpName, para) import Michelson.Untyped hiding (Contract) @@ -35,7 +40,7 @@ -- or anything else relevant. type ContractPropValidator st prop = ContractReturn st -> prop --- | Contract's property tester against given input. +-- | ContractCode's property tester against given input. -- Takes contract environment, initial storage and parameter, -- interprets contract on this input and invokes validation function. contractProp @@ -43,7 +48,7 @@ , ToT param ~ cp, ToT storage ~ st , T.ParameterScope cp ) - => Contract cp st + => FullContract cp st -> ContractPropValidator st prop -> ContractEnv -> param @@ -61,14 +66,14 @@ -- by "Michelson.Test.Integrational" module. contractPropVal :: (T.ParameterScope cp) - => Contract cp st + => FullContract cp st -> ContractPropValidator st prop -> ContractEnv -> T.Value cp -> T.Value st -> prop contractPropVal instr check env param initSt = - check $ interpret instr T.epcCallRootUnsafe param initSt env + check $ interpret (T.fcCode instr) T.epcCallRootUnsafe param initSt env -- | Check if entrypoint is present in `T`. hasEp :: T -> (EpName, U.Type) -> Bool @@ -100,6 +105,14 @@ conv l | null l = Right () | otherwise = Left $ fromList l +---------------------------------------------------------------------------- +-- Validators +---------------------------------------------------------------------------- + +-- | 'ContractPropValidator' that expects a successful termination. +validateSuccess :: HasCallStack => ContractPropValidator st Expectation +validateSuccess (res, _) = res `shouldSatisfy` isRight + -- | 'ContractPropValidator' that expects contract execution to -- succeed and update storage to a particular constant value. validateStorageIs @@ -111,3 +124,9 @@ assertFailure $ "Unexpected interpretation failure: " +| err |+ "" Right (_ops, got) -> got @?= toVal expected + +-- | 'ContractPropValidator' that expects a given failure. +validateMichelsonFailsWith + :: (T.IsoValue v, Typeable (ToT v), SingI (ToT v)) + => v -> ContractPropValidator st Expectation +validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v) diff --git a/src/Michelson/Text.hs b/src/Michelson/Text.hs --- a/src/Michelson/Text.hs +++ b/src/Michelson/Text.hs @@ -35,13 +35,14 @@ import qualified Data.Char as C import Data.Data (Data) import qualified Data.Text as T -import Data.Vinyl.Derived (Label) import Fmt (Buildable) import GHC.TypeLits (ErrorMessage(..), TypeError) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import Test.QuickCheck (Arbitrary(..), choose, listOf) +import Util.CLI +import Util.Label (Label(..), labelToText) import Util.TypeLits -- | Michelson string value. @@ -66,9 +67,11 @@ -- * With 'mkMTextCut' when not sure about text contents and want -- to make it compliant with Michelson constraints. newtype MText = MTextUnsafe { unMText :: Text } - deriving stock (Show, Eq, Ord, Data) + deriving stock (Show, Eq, Ord, Data, Generic) deriving newtype (Semigroup, Monoid, Container, Buildable, Hashable) +instance NFData MText + -- | Constraint on literals appearing in Michelson contract code. isMChar :: Char -> Bool isMChar c = fromEnum c >= 32 && fromEnum c <= 126 @@ -129,6 +132,10 @@ parseJSON v = either (fail . toString) pure . mkMText =<< parseJSON @Text v +instance HasCLReader MText where + getReader = eitherReader (first toString . mkMText . toText) + getMetavar = "MICHELSON STRING" + -- | QuasyQuoter for constructing Michelson strings. -- -- Validity of result will be checked at compile time. @@ -201,8 +208,8 @@ -- -- We assume that no unicode characters are used in plain Haskell code, -- so unless special tricky manipulations are used this should be safe. -labelToMText :: KnownSymbol name => Label name -> MText -labelToMText (_ :: Label name) = symbolToMText @name +labelToMText :: Label name -> MText +labelToMText = mkMTextUnsafe . labelToText -- | Leads first character of text to upper case. -- diff --git a/src/Michelson/TypeCheck.hs b/src/Michelson/TypeCheck.hs --- a/src/Michelson/TypeCheck.hs +++ b/src/Michelson/TypeCheck.hs @@ -3,7 +3,6 @@ , typeCheckTopLevelType , typeVerifyTopLevelType , typeCheckValue - , typeVerifyValue , typeCheckList , typeCheckCValue , typeCheckExt diff --git a/src/Michelson/TypeCheck/Error.hs b/src/Michelson/TypeCheck/Error.hs --- a/src/Michelson/TypeCheck/Error.hs +++ b/src/Michelson/TypeCheck/Error.hs @@ -29,8 +29,10 @@ | NotEnoughDip | NotEnoughDig | NotEnoughDug - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData NotEnoughItemsInstr + instance Buildable NotEnoughItemsInstr where build = \case NotEnoughDrop -> "DROP" @@ -76,8 +78,10 @@ -- ^ KeyHash couldn't be parsed from its textual representation | InvalidTimestamp -- ^ Timestamp is not RFC339 compliant - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData TCTypeError + instance Buildable TCTypeError where build = \case AnnError e -> build e @@ -110,8 +114,10 @@ | TCContractError Text (Maybe TCTypeError) | TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp) | TCExtError SomeHST InstrCallStack ExtError - deriving stock (Eq) + deriving stock (Eq, Generic) +instance NFData TCError + -- TODO pva701: an instruction position should be used in -- Buildable instance within TM-151. instance Buildable TCError where @@ -145,8 +151,10 @@ instance Buildable U.ExpandedInstr => Exception TCError newtype StackSize = StackSize Natural - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData StackSize + -- | Various type errors possible when checking Morley extension commands data ExtError = LengthMismatch U.StackTypePattern @@ -156,7 +164,9 @@ | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError | TestAssertError Text | InvalidStackReference U.StackRef StackSize - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance NFData ExtError instance Buildable ExtError where build = \case diff --git a/src/Michelson/TypeCheck/Ext.hs b/src/Michelson/TypeCheck/Ext.hs --- a/src/Michelson/TypeCheck/Ext.hs +++ b/src/Michelson/TypeCheck/Ext.hs @@ -6,7 +6,6 @@ import Control.Lens ((%=)) import Control.Monad.Except (MonadError, liftEither, throwError) import Data.Map.Lazy (Map, insert, lookup) -import Data.Singletons (Sing) import Data.Typeable ((:~:)(..)) import Michelson.ErrorPos @@ -14,9 +13,8 @@ import Michelson.TypeCheck.Helpers import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types -import Michelson.Typed (Notes(..), converge, mkUType, withUType) +import Michelson.Typed (Notes(..), converge, mkUType, notesT, withUType) import qualified Michelson.Typed as T -import Michelson.Typed.Sing (fromSingT) import Michelson.Untyped (CT(..), ExpandedOp, StackFn, TyVar(..), Type, Var, VarAnn, inPattern, outPattern, quantifiedVars, varSet) @@ -47,7 +45,7 @@ case si of AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError "TEST_ASSERT has to return Bool, but it always fails" - instr ::: (((_ :: (Sing b, T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do + instr ::: (((_ :: (T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do Refl <- liftEither $ first (const $ TCExtError (SomeHST hst) instrPos $ TestAssertError "TEST_ASSERT has to return Bool, but returned something else") $ @@ -127,20 +125,20 @@ go m _ U.StkEmpty SNil = pure $ BoundVars m Nothing go _ _ U.StkEmpty _ = Left $ LengthMismatch s go _ _ _ SNil = Left $ LengthMismatch s - go m n (U.StkCons tyVar ts) ((xt :: Sing xt, xann :: Notes xt, _) ::& xs) = + go m n (U.StkCons tyVar ts) ((xann :: Notes xt, _) ::& xs) = let handleType :: U.Type -> Either ExtError BoundVars handleType t = - withUType t $ \(tsing :: Sing t, tann :: Notes t) -> do + withUType t $ \(tann :: Notes t) -> do Refl <- first - (\_ -> TypeMismatch s n $ TypeEqError (fromSingT xt) (fromSingT tsing)) + (\_ -> TypeMismatch s n $ TypeEqError (notesT xann) (notesT tann)) (eqType @xt @t) void $ first (TypeMismatch s n . AnnError) (converge tann xann) go m (n + 1) ts xs in case tyVar of TyCon t -> handleType t VarID v -> case lookup v m of - Nothing -> let t = mkUType xt xann in go (insert v t m) (n + 1) ts xs + Nothing -> let t = mkUType xann in go (insert v t m) (n + 1) ts xs Just t -> handleType t -- | Create stack reference accessing element with a given index. diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs --- a/src/Michelson/TypeCheck/Helpers.hs +++ b/src/Michelson/TypeCheck/Helpers.hs @@ -52,7 +52,7 @@ import Michelson.TypeCheck.TypeCheck import Michelson.TypeCheck.Types import Michelson.Typed - (CT(..), Instr(..), Notes(..), PackedNotes(..), Sing(..), T(..), converge, fromSingT, orAnn, + (CT(..), Instr(..), Notes(..), PackedNotes(..), Sing(..), T(..), converge, notesT, orAnn, starNotes) import Michelson.Typed.Annotation (AnnConvergeError, isStar) import Michelson.Typed.Arith (Add, ArithOp(..), Mul, Sub, UnaryArithOp(..)) @@ -123,12 +123,12 @@ in (an, avn) convergeHSTEl - :: (Sing t, Notes t, VarAnn) - -> (Sing t, Notes t, VarAnn) - -> Either AnnConvergeError (Sing t, Notes t, VarAnn) -convergeHSTEl (at, an, avn) (_, bn, bvn) = - (,,) at <$> converge an bn - <*> pure (bool def avn $ avn == bvn) + :: (Notes t, VarAnn) + -> (Notes t, VarAnn) + -> Either AnnConvergeError (Notes t, VarAnn) +convergeHSTEl (an, avn) (bn, bvn) = + (,) <$> converge an bn + <*> pure (bool def avn $ avn == bvn) -- | Combine annotations from two given stack types convergeHST :: HST ts -> HST ts -> Either AnnConvergeError (HST ts) @@ -144,7 +144,7 @@ hstToTs :: HST st -> [T] hstToTs = \case SNil -> [] - (s, _, _) ::& hst -> fromSingT s : hstToTs hst + (notes, _) ::& hst -> notesT notes : hstToTs hst -- | Check whether the given stack types are equal. eqHST @@ -304,8 +304,8 @@ wrapWithNotes :: HST d -> Instr c d -> Instr c d wrapWithNotes h ins = case h of -- do not wrap in notes if the notes are "star" - ((_, n, _) ::& _) | isStar n -> ins - ((s, n, _) ::& _) -> InstrWithNotes (PackedNotes n s) ins + ((n, _) ::& _) | isStar n -> ins + ((n, _) ::& _) -> InstrWithNotes (PackedNotes n) ins SNil -> ins extractInstrPos :: Un.ExpandedOp -> InstrCallStack @@ -340,7 +340,7 @@ memImpl instr i@(_ ::& _ ::& rs) vn = do pos <- ask case eqType @('Tc q) @('Tc (MemOpKey c)) of - Right Refl -> pure $ i :/ MEM ::: ((STc SCBool, starNotes, vn) ::& rs) + Right Refl -> pure $ i :/ MEM ::: ((starNotes, vn) ::& rs) Left m -> throwError $ TCFailedOnInstr instr (SomeHST i) "query element type is not equal to set's element type" pos (Just m) @@ -355,16 +355,15 @@ ) => Un.ExpandedInstr -> HST (getKey ': c ': rs) - -> Sing (GetOpVal c) -> Notes (GetOpVal c) -> VarAnn -> m (SomeInstr inp) -getImpl instr i@(_ ::& _ ::& rs) rt vns vn = do +getImpl instr i@(_ ::& _ ::& rs) vns vn = do pos <- ask case eqType @getKey @('Tc (GetOpKey c)) of Right Refl -> do let rn = NTOption def vns - pure $ i :/ GET ::: ((STOption rt, rn, vn) ::& rs) + pure $ i :/ GET ::: ((rn, vn) ::& rs) Left m -> throwError $ TCFailedOnInstr instr (SomeHST i) "wrong key stack type" pos (Just m) updImpl @@ -384,7 +383,7 @@ pos <- ask case (eqType @updKey @('Tc (UpdOpKey c)), eqType @updParams @(UpdOpParams c)) of (Right Refl, Right Refl) -> - pure $ i :/ UPDATE ::: ((cTuple & _3 .~ vn) ::& rest) + pure $ i :/ UPDATE ::: ((cTuple & _2 .~ vn) ::& rest) (Left m, _) -> throwError $ TCFailedOnInstr instr (SomeHST i) "wrong key stack type" pos (Just m) (_, Left m) -> throwError $ TCFailedOnInstr instr (SomeHST i) @@ -396,25 +395,25 @@ -> VarAnn -> m (SomeInstr inp) sizeImpl i@(_ ::& rs) vn = - pure $ i :/ SIZE ::: ((STc SCNat, starNotes, vn) ::& rs) + pure $ i :/ SIZE ::: ((starNotes, vn) ::& rs) sliceImpl :: (SliceOp c, Typeable c, inp ~ ('Tc 'CNat ': 'Tc 'CNat ': c ': rs), Monad m) => HST inp -> Un.VarAnn -> m (SomeInstr inp) -sliceImpl i@(_ ::& _ ::& (c, cn, cvn) ::& rs) vn = do +sliceImpl i@(_ ::& _ ::& (cn, cvn) ::& rs) vn = do let vn' = vn `orAnn` deriveVN "slice" cvn rn = NTOption def cn - pure $ i :/ SLICE ::: ((STOption c, rn, vn') ::& rs) + pure $ i :/ SLICE ::: ((rn, vn') ::& rs) concatImpl' - :: (ConcatOp c, Typeable c, inp ~ ('TList c : rs), Monad m) + :: (ConcatOp c, Typeable c, SingI c, inp ~ ('TList c : rs), Monad m) => HST inp -> Un.VarAnn -> m (SomeInstr inp) -concatImpl' i@((STList c, NTList _ n, _) ::& rs) vn = do - pure $ i :/ CONCAT' ::: ((c, n, vn) ::& rs) +concatImpl' i@((NTList _ n, _) ::& rs) vn = do + pure $ i :/ CONCAT' ::: ((n, vn) ::& rs) concatImpl :: ( ConcatOp c, Typeable c, inp ~ (c ': c ': rs) @@ -424,9 +423,9 @@ => HST inp -> Un.VarAnn -> m (SomeInstr inp) -concatImpl i@((c, cn1, _) ::& (_, cn2, _) ::& rs) vn = do +concatImpl i@((cn1, _) ::& (cn2, _) ::& rs) vn = do cn <- onTypeCheckInstrAnnErr (Un.CONCAT vn) i "wrong operand types for concat operation" (converge cn1 cn2) - pure $ i :/ CONCAT ::: ((c, cn, vn) ::& rs) + pure $ i :/ CONCAT ::: ((cn, vn) ::& rs) -- | Helper function to construct instructions for binary arithmetic -- operations. @@ -442,7 +441,7 @@ -> VarAnn -> t (SomeInstr inp) arithImpl mkInstr i@(_ ::& _ ::& rs) vn = do - pure $ i :/ mkInstr ::: ((sing, starNotes, vn) ::& rs) + pure $ i :/ mkInstr ::: ((starNotes, vn) ::& rs) addImpl :: forall a b inp rs m. @@ -504,7 +503,7 @@ -> VarAnn -> t (SomeInstr inp) edivImplDo i@(_ ::& _ ::& rs) vn = do - pure $ i :/ EDIV ::: ((sing, starNotes, vn) ::& rs) + pure $ i :/ EDIV ::: ((starNotes, vn) ::& rs) subImpl :: forall a b inp rs m. @@ -567,4 +566,4 @@ -> VarAnn -> t (SomeInstr inp) unaryArithImpl mkInstr i@(_ ::& rs) vn = do - pure $ i :/ mkInstr ::: ((sing, starNotes, vn) ::& rs) + pure $ i :/ mkInstr ::: ((starNotes, vn) ::& rs) diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs --- a/src/Michelson/TypeCheck/Instr.hs +++ b/src/Michelson/TypeCheck/Instr.hs @@ -27,7 +27,6 @@ module Michelson.TypeCheck.Instr ( typeCheckContract , typeCheckValue - , typeVerifyValue , typeCheckList , typeVerifyTopLevelType , typeCheckTopLevelType @@ -40,7 +39,7 @@ import Data.Default (def) import Data.Generics (everything, mkQ) import Data.Singletons (SingI(sing), demote) -import Data.Typeable ((:~:)(..), gcast) +import Data.Typeable ((:~:)(..)) import Michelson.ErrorPos import Michelson.TypeCheck.Error @@ -68,22 +67,22 @@ typeCheckContractImpl (U.Contract mParam mStorage pCode) = do code <- maybe (throwError $ TCContractError "no instructions in contract code" Nothing) pure (nonEmpty pCode) - withUType mParam $ \(paramS :: Sing param, paramNote :: Notes param) -> - withUType mStorage $ \(storageS :: Sing st, storageNote :: Notes st) -> do + withUType mParam $ \(paramNote :: Notes param) -> + withUType mStorage $ \(storageNote :: Notes st) -> do (Dict, Dict) <- - note (hasTypeError "parameter" paramS) $ - (,) <$> opAbsense paramS - <*> nestedBigMapsAbsense paramS + note (hasTypeError "parameter" paramNote) $ + (,) <$> opAbsense (notesSing paramNote) + <*> nestedBigMapsAbsense (notesSing paramNote) (Dict, Dict, Dict) <- - note (hasTypeError "storage" storageS) $ - (,,) <$> opAbsense storageS - <*> nestedBigMapsAbsense storageS - <*> contractTypeAbsense storageS + note (hasTypeError "storage" storageNote) $ + (,,) <$> opAbsense (notesSing storageNote) + <*> nestedBigMapsAbsense (notesSing storageNote) + <*> contractTypeAbsense (notesSing storageNote) let inpNote = NTPair def def def paramNote storageNote - let inp = (STPair paramS storageS, inpNote, def) ::& SNil + let inp = (inpNote, def) ::& SNil inp' :/ instrOut <- typeCheckNE code inp let (paramNotesRaw, fcStoreNotes) = case inp' of - (_, NTPair _ _ _ cpNotes stNotes, _) ::& SNil -> (cpNotes, stNotes) + (NTPair _ _ _ cpNotes stNotes, _) ::& SNil -> (cpNotes, stNotes) fcParamNotesSafe <- liftEither $ mkParamNotes paramNotesRaw `onLeft` @@ -92,7 +91,7 @@ instr ::: out -> liftEither $ do case eqHST1 @(ContractOut1 st) out of Right Refl -> do - let (_, outN, _) ::& SNil = out + let (outN, _) ::& SNil = out _ <- converge outN (NTPair def def def starNotes storageNote) `onLeft` ((TCContractError "contract output type violates convention:") . Just . AnnError) @@ -138,7 +137,7 @@ -- given in representation from @Michelson.Untyped@ module hierarchy to -- representation in strictly typed GADT. -- --- As a second argument, @typeCheckValue@ accepts expected type of value. +-- @typeCheckValue@ is polymorphic in the expected type of value. -- -- Type checking algorithm pattern-matches on parse value representation, -- expected type @t@ and constructs @Val t@ value. @@ -147,26 +146,18 @@ -- that is interpreted as input of wrong type and type check finishes with -- error. typeCheckValue - :: U.Value - -> (Sing t, Notes t) - -> TypeCheckInstr SomeNotedValue -typeCheckValue = typeCheckValImpl typeCheckInstr - --- | Like 'typeCheckValue', but returns value of a desired type. -typeVerifyValue :: forall t. - (Typeable t, SingI t) - => U.Value -> TypeCheckInstr (Value t) -typeVerifyValue uval = - typeCheckValue uval (sing @t, starNotes) <&> \case - val :::: _ -> gcast val ?: error "Typechecker produced value of wrong type" + (SingI t) + => U.Value + -> TypeCheckInstr (Value t) +typeCheckValue = typeCheckValImpl @t typeCheckInstr typeVerifyTopLevelType - :: (Typeable t, SingI t, HasCallStack) + :: (SingI t, HasCallStack) => TcOriginatedContracts -> U.Value -> Either TCError (Value t) typeVerifyTopLevelType originatedContracts valueU = runTypeCheck param originatedContracts $ usingReaderT (def :: InstrCallStack) $ - typeVerifyValue valueU + typeCheckValue valueU where param = error "parameter type touched during top-level type typecheck" @@ -282,169 +273,161 @@ (SomeHST i) "" (Left (NotEnoughItemsOnStack nTotal NotEnoughDug)) (U.PUSH vn mt mval, i) -> - withUType mt $ \(t' :: Sing t', nt' :: Notes t') -> do - val :::: (t :: Sing t, nt) <- typeCheckValue mval (t', nt') + withUType mt $ \(nt :: Notes t) -> do + val <- typeCheckValue @t mval proofOp <- maybe (onTypeCheckInstrErr uInstr (SomeHST i) "Operations in constant are not allowed" $ Left $ UnsupportedTypes [demote @t]) - pure (opAbsense t) + pure (opAbsense $ notesSing nt) proofBigMap <- maybe (onTypeCheckInstrErr uInstr (SomeHST i) "BigMaps in constant are not allowed" $ Left $ UnsupportedTypes [demote @t]) - pure (bigMapAbsense t) + pure (bigMapAbsense $ notesSing nt) proofContract <- maybe (onTypeCheckInstrErr uInstr (SomeHST i) "Contract type in constant is not allowed" $ Left $ UnsupportedTypes [demote @t]) - pure (contractTypeAbsense t) + pure (contractTypeAbsense $ notesSing nt) case (proofOp, proofBigMap, proofContract) of - (Dict, Dict, Dict) -> pure $ i :/ PUSH val ::: ((t, nt, vn) ::& i) + (Dict, Dict, Dict) -> pure $ i :/ PUSH val ::: ((nt, vn) ::& i) - (U.SOME tn vn, (at, an, _) ::& rs) -> do - pure (inp :/ SOME ::: ((STOption at, NTOption tn an, vn) ::& rs)) + (U.SOME tn vn, (an, _) ::& rs) -> do + pure (inp :/ SOME ::: ((NTOption tn an, vn) ::& rs)) (U.NONE tn vn elMt, _) -> - withUType elMt $ \(elSing :: Sing t, elNotes :: Notes t) -> - pure $ inp :/ NONE ::: ((STOption elSing, NTOption tn elNotes, vn) ::& inp) + withUType elMt $ \elNotes -> + pure $ inp :/ NONE ::: ((NTOption tn elNotes, vn) ::& inp) (U.UNIT tn vn, _) -> - pure $ inp :/ UNIT ::: ((STUnit, NTUnit tn, vn) ::& inp) + pure $ inp :/ UNIT ::: ((NTUnit tn, vn) ::& inp) - (U.IF_NONE mp mq, (STOption a, ons, ovn) ::& rs) -> do + (U.IF_NONE mp mq, (STOption{}, ons, ovn) ::&+ rs) -> do let (an, avn) = deriveNsOption ons ovn - genericIf IF_NONE U.IF_NONE mp mq rs ((a, an, avn) ::& rs) inp + genericIf IF_NONE U.IF_NONE mp mq rs ((an, avn) ::& rs) inp - (U.PAIR tn vn pfn qfn, (a, an, avn) ::& (b, bn, bvn) ::& rs) -> do + (U.PAIR tn vn pfn qfn, (an, avn) ::& (bn, bvn) ::& rs) -> do let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn ns = NTPair tn pfn' qfn' an bn - pure (inp :/ PAIR ::: ((STPair a b, ns, vn `orAnn` vn') ::& rs)) + pure (inp :/ PAIR ::: ((ns, vn `orAnn` vn') ::& rs)) - (U.CAR vn fn, ( STPair a b - , NTPair pairTN pfn qfn pns qns - , pairVN ) ::& rs) -> do + (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn pns qns, pairVN) ::&+ rs) -> do pfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong car type:" (convergeAnns fn pfn) let vn' = deriveSpecialVN vn pfn' pairVN - i' = ( STPair a b - , NTPair pairTN pfn' qfn pns qns - , pairVN ) ::& rs - pure $ i' :/ AnnCAR fn ::: ((a, pns, vn') ::& rs) + i' = (NTPair pairTN pfn' qfn pns qns, pairVN) ::& rs + pure $ i' :/ AnnCAR fn ::: ((pns, vn') ::& rs) - (U.CDR vn fn, ( STPair a b - , NTPair pairTN pfn qfn pns qns - , pairVN ) ::& rs) -> do + (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn pns qns, pairVN) ::&+ rs) -> do qfn' <- onTypeCheckInstrAnnErr uInstr inp "wrong cdr type:" (convergeAnns fn qfn) let vn' = deriveSpecialVN vn qfn' pairVN - i' = ( STPair a b - , NTPair pairTN pfn qfn' pns qns - , pairVN ) ::& rs - pure $ i' :/ AnnCDR fn ::: ((b, qns, vn') ::& rs) + i' = (NTPair pairTN pfn qfn' pns qns, pairVN) ::& rs + pure $ i' :/ AnnCDR fn ::: ((qns, vn') ::& rs) - (U.LEFT tn vn pfn qfn bMt, (a, an, _) ::& rs) -> - withUType bMt $ \(b :: Sing b, bn :: Notes b) -> do + (U.LEFT tn vn pfn qfn bMt, (an, _) ::& rs) -> + withUType bMt $ \bn -> do let ns = NTOr tn pfn qfn an bn - pure (inp :/ LEFT ::: ((STOr a b, ns, vn) ::& rs)) + pure (inp :/ LEFT ::: ((ns, vn) ::& rs)) - (U.RIGHT tn vn pfn qfn aMt, (b, bn, _) ::& rs) -> - withUType aMt $ \(a :: Sing a, an :: Notes a) -> do + (U.RIGHT tn vn pfn qfn aMt, (bn, _) ::& rs) -> + withUType aMt $ \an -> do let ns = NTOr tn pfn qfn an bn - pure (inp :/ RIGHT ::: ((STOr a b, ns, vn) ::& rs)) + pure (inp :/ RIGHT ::: ((ns, vn) ::& rs)) - (U.IF_LEFT mp mq, (STOr a b, ons, ovn) ::& rs) -> do + (U.IF_LEFT mp mq, (STOr{}, ons, ovn) ::&+ rs) -> do let (an, bn, avn, bvn) = deriveNsOr ons ovn - ait = (a, an, avn) ::& rs - bit = (b, bn, bvn) ::& rs + ait = (an, avn) ::& rs + bit = (bn, bvn) ::& rs genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp (U.NIL tn vn elMt, i) -> - withUType elMt $ \(elT :: Sing elT, elNotes :: Notes elT) -> - pure $ i :/ NIL ::: ((STList elT, NTList tn elNotes, vn) ::& i) + withUType elMt $ \elNotes -> + pure $ i :/ NIL ::: ((NTList tn elNotes, vn) ::& i) - (U.CONS vn, ((at :: Sing a), an, _) - ::& (STList (_ :: Sing a'), ln, _) ::& rs) -> - case eqType @a @a' of + (U.CONS vn, ((an :: Notes a), _) + ::& ((ln :: Notes l), _) ::& rs) -> + case eqType @('TList a) @l of Right Refl -> do n <- onTypeCheckInstrAnnErr uInstr inp "wrong cons type:" (converge ln (NTList def an)) - pure $ inp :/ CONS ::: ((STList at, n, vn) ::& rs) + pure $ inp :/ CONS ::: ((n, vn) ::& rs) Left m -> onTypeCheckInstrErr uInstr (SomeHST inp) ("list element type is different from one " <> "that is being CONSed:") (Left m) - (U.IF_CONS mp mq, (STList a, ns, vn) ::& rs) -> do + (U.IF_CONS mp mq, (STList{}, ns, vn) ::&+ rs) -> do let NTList _ an = ns - ait = (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs + ait = (an, vn <> "hd") ::& (ns, vn <> "tl") ::& rs genericIf IF_CONS U.IF_CONS mp mq ait rs inp - (U.SIZE vn, (STList _, _, _) ::& _) -> sizeImpl inp vn - (U.SIZE vn, (STSet _, _, _) ::& _) -> sizeImpl inp vn - (U.SIZE vn, (STMap _ _, _, _) ::& _) -> sizeImpl inp vn - (U.SIZE vn, (STc SCString, _, _) ::& _) -> sizeImpl inp vn - (U.SIZE vn, (STc SCBytes, _, _) ::& _) -> sizeImpl inp vn + (U.SIZE vn, (NTList{}, _) ::& _) -> sizeImpl inp vn + (U.SIZE vn, (NTSet{}, _) ::& _) -> sizeImpl inp vn + (U.SIZE vn, (NTMap{}, _) ::& _) -> sizeImpl inp vn + (U.SIZE vn, (NTcs SCString, _) ::& _) -> sizeImpl inp vn + (U.SIZE vn, (NTcs SCBytes, _) ::& _) -> sizeImpl inp vn (U.EMPTY_SET tn vn (U.Comparable mk ktn), i) -> withSomeSingCT mk $ \k -> - pure $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, vn) ::& inp) + pure $ i :/ EMPTY_SET ::: ((STSet k, NTSet tn ktn, vn) ::&+ inp) (U.EMPTY_MAP tn vn (U.Comparable mk ktn) mv, i) -> - withUType mv $ \(v :: Sing v, vns :: Notes v) -> + withUType mv $ \vns -> withSomeSingCT mk $ \k -> do let ns = NTMap tn ktn vns - pure $ i :/ EMPTY_MAP ::: ((STMap k v, ns, vn) ::& i) + pure $ i :/ EMPTY_MAP ::: ((STMap k sing, ns, vn) ::&+ i) (U.EMPTY_BIG_MAP tn vn (U.Comparable mk ktn) mv, i) -> - withUType mv $ \(v :: Sing v, vns :: Notes v) -> + withUType mv $ \vns -> withSomeSingCT mk $ \k -> do let ns = NTBigMap tn ktn vns - pure $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k v, ns, vn) ::& i) + pure $ i :/ EMPTY_BIG_MAP ::: ((STBigMap k sing, ns, vn) ::&+ i) - (U.MAP vn mp, (STList _, NTList _ vns, _vn) ::& _) -> do + (U.MAP vn mp, (STList _, NTList _ vns, _vn) ::&+ _) -> do mapImpl vns uInstr mp inp - (\rt rn -> (::&) (STList rt, NTList def rn, vn)) + (\rn -> (::&) (NTList def rn, vn)) - (U.MAP vn mp, (STMap k _, NTMap _ kns vns, _vn) ::& _) -> do + (U.MAP vn mp, (STMap{}, NTMap _ kns vns, _vn) ::&+ _) -> do let pns = NTPair def def def (NTc kns) vns mapImpl pns uInstr mp inp - (\rt rn -> (::&) (STMap k rt, NTMap def kns rn, vn)) + (\rn -> (::&) (NTMap def kns rn, vn)) -- case `U.HSTER []` is wrongly typed by definition -- (as it is required to at least drop an element), so we don't consider it - (U.ITER (i1 : ir), (STSet _, NTSet _ en, _) ::& _) -> do + (U.ITER (i1 : ir), (STSet _, NTSet _ en, _) ::&+ _) -> do iterImpl (NTc en) uInstr (i1 :| ir) inp - (U.ITER (i1 : ir), (STList _, NTList _ en, _) ::& _) -> do + (U.ITER (i1 : ir), (STList _, NTList _ en, _) ::&+ _) -> do iterImpl en uInstr (i1 :| ir) inp - (U.ITER (i1 : ir), (STMap _ _, NTMap _ kns vns, _) ::& _) -> do + (U.ITER (i1 : ir), (STMap _ _, NTMap _ kns vns, _) ::&+ _) -> do let en = NTPair def def def (NTc kns) vns iterImpl en uInstr (i1 :| ir) inp - (U.MEM vn, (STc _, _, _) ::& (STSet _, _, _) ::& _) -> + (U.MEM vn, (NTc _, _) ::& (STSet{}, NTSet{}, _) ::&+ _) -> memImpl uInstr inp vn - (U.MEM vn, (STc _, _, _) ::& (STMap _ _, _, _) ::& _) -> + (U.MEM vn, (NTc _, _) ::& (STMap{}, NTMap{}, _) ::&+ _) -> memImpl uInstr inp vn - (U.MEM vn, (STc _, _, _) ::& (STBigMap _ _, _, _) ::& _) -> + (U.MEM vn, (NTc _, _) ::& (STBigMap{}, NTBigMap{}, _) ::&+ _) -> memImpl uInstr inp vn - (U.GET vn, _ ::& (STMap _ vt, NTMap _ _ v, _) ::& _) -> - getImpl uInstr inp vt v vn - (U.GET vn, _ ::& (STBigMap _ vt, NTBigMap _ _ v, _) ::& _) -> - getImpl uInstr inp vt v vn + (U.GET vn, _ ::& (STMap{}, NTMap _ _ v, _) ::&+ _) -> + getImpl uInstr inp v vn + (U.GET vn, _ ::& (STBigMap{}, NTBigMap _ _ v, _) ::&+ _) -> + getImpl uInstr inp v vn - (U.UPDATE vn, _ ::& _ ::& (STMap _ _, _, _) ::& _) -> + (U.UPDATE vn, _ ::& _ ::& (STMap _ _, _, _) ::&+ _) -> updImpl uInstr inp vn - (U.UPDATE vn, _ ::& _ ::& (STBigMap _ _, _, _) ::& _) -> + (U.UPDATE vn, _ ::& _ ::& (STBigMap _ _, _, _) ::&+ _) -> updImpl uInstr inp vn - (U.UPDATE vn, _ ::& _ ::& (STSet _, _, _) ::& _) -> + (U.UPDATE vn, _ ::& _ ::& (STSet _, _, _) ::&+ _) -> updImpl uInstr inp vn - (U.IF mp mq, (STc SCBool, _, _) ::& rs) -> + (U.IF mp mq, (NTcs SCBool, _) ::& rs) -> genericIf IF U.IF mp mq rs rs inp - (U.LOOP is, (STc SCBool, _, _) ::& (rs :: HST rs)) -> do + (U.LOOP is, (NTcs SCBool, _) ::& (rs :: HST rs)) -> do _ :/ tp <- lift $ typeCheckList is rs case tp of subI ::: (o :: HST o) -> do @@ -457,49 +440,46 @@ AnyOutInstr subI -> pure $ inp :/ LOOP subI ::: rs - (U.LOOP_LEFT is, (STOr (at :: Sing a) (bt :: Sing b), ons, ovn) ::& rs) -> do + (U.LOOP_LEFT is, (os@STOr{}, ons, ovn) ::&+ rs) -> do let (an, bn, avn, bvn) = deriveNsOr ons ovn - ait = (at, an, avn) ::& rs + ait = (an, avn) ::& rs _ :/ tp <- lift $ typeCheckList is ait case tp of subI ::: o -> do - case (eqHST o (sing @('TOr a b) -:& rs), o) of - (Right Refl, ((STOr _ bt', ons', ovn') ::& rs')) -> do + case (eqHST o (os -:& rs), o) of + (Right Refl, ((ons', ovn') ::& rs')) -> do let (_, bn', _, bvn') = deriveNsOr ons' ovn' br <- onTypeCheckInstrAnnErr uInstr inp "wrong LOOP_LEFT input type:" $ - convergeHSTEl (bt, bn, bvn) (bt', bn', bvn') + convergeHSTEl (bn, bvn) (bn', bvn') pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs') (Left m, _) -> onTypeCheckInstrErr uInstr (SomeHST inp) "iteration expression has wrong output stack type:" (Left m) AnyOutInstr subI -> do - let br = (bt, bn, bvn) + let br = (bn, bvn) pure $ inp :/ LOOP_LEFT subI ::: (br ::& rs) - (U.LAMBDA vn imt omt is, i) -> do - withUType imt $ \(it :: Sing it, ins :: Notes ins) -> - withUType omt $ \(ot :: Sing ot, ons :: Notes ons) -> - -- further processing is extracted into another function because - -- otherwise I encountered some weird GHC error with that code - -- located right here - lamImpl uInstr is vn it ins ot ons i + (U.LAMBDA vn (AsUType ins) (AsUType ons) is, i) -> do + -- further processing is extracted into another function just not to + -- litter our main typechecking logic + lamImpl uInstr is vn ins ons i - (U.EXEC vn, ((_ :: Sing t1), _, _) - ::& ( STLambda (_ :: Sing t1') t2 - , NTLambda _ _ t2n + (U.EXEC vn, ((_ :: Notes t1), _) + ::& ( STLambda _ _ + , NTLambda _ (_ :: Notes t1') t2n , _ ) - ::& rs) -> do + ::&+ rs) -> do Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) "lambda is given argument with wrong type:" (eqType @t1 @t1') - pure $ inp :/ EXEC ::: ((t2, t2n, vn) ::& rs) + pure $ inp :/ EXEC ::: ((t2n, vn) ::& rs) - (U.APPLY vn, ((_ :: Sing a'), _, _) - ::& (STLambda (STPair (sa :: Sing a) (sb :: Sing b)) sc, ln, _) - ::& rs) -> do + (U.APPLY vn, ((_ :: Notes a'), _) + ::& ( STLambda (STPair sa _) _ + , NTLambda vann (NTPair _ _ _ (_ :: Notes a) (nb :: Notes b)) sc + , _) + ::&+ rs) -> do let - l2n = case ln of - NTLambda vann (NTPair _ _ _ _ bn) cn -> - NTLambda vann bn cn + l2n = NTLambda vann nb sc proofArgEq <- onTypeCheckInstrErr uInstr (SomeHST inp) "lambda is given argument with wrong type:" (eqType @a' @a) @@ -520,7 +500,7 @@ pure (contractTypeAbsense sa) case (proofArgEq, proofOp, proofBigMap, proofContract) of (Refl, Dict, Dict, Dict) -> - pure $ inp :/ (APPLY @a) ::: ((STLambda sb sc, l2n, vn) ::& rs) + pure $ inp :/ (APPLY @a) ::: ((l2n, vn) ::& rs) (U.DIP is, a ::& s) -> do typeCheckDipBody uInstr is s $ @@ -546,109 +526,109 @@ (U.FAILWITH, (_ ::& _)) -> pure $ inp :/ AnyOutInstr FAILWITH - (U.CAST vn (AsUType _ castToNotes), (e, en, evn) ::& rs) -> do + (U.CAST vn (AsUType castToNotes), (en, evn) ::& rs) -> do (Refl, _) <- errM $ matchTypes en castToNotes - pure $ inp :/ CAST ::: ((e, castToNotes, vn `orAnn` evn) ::& rs) + pure $ inp :/ CAST ::: ((castToNotes, vn `orAnn` evn) ::& rs) where errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a errM = onTypeCheckInstrErr uInstr (SomeHST inp) "cast to incompatible type:" - (U.RENAME vn, (at, an, _) ::& rs) -> - pure $ inp :/ RENAME ::: ((at, an, vn) ::& rs) + (U.RENAME vn, (an, _) ::& rs) -> + pure $ inp :/ RENAME ::: ((an, vn) ::& rs) - (U.UNPACK tn vn mt, (STc SCBytes, _, _) ::& rs) -> - withUType mt $ \(t, tns) -> do + (U.UNPACK tn vn mt, (NTcs SCBytes, _) ::& rs) -> + withUType mt $ \tns -> do let ns = NTOption tn tns proofOp <- maybe (typeCheckInstrErr uInstr (SomeHST inp) "Operation cannot appear in serialized data") - pure (opAbsense t) + pure (opAbsense $ notesSing tns) proofBigMap <- maybe (typeCheckInstrErr uInstr (SomeHST inp) "BigMap cannot appear in serialized data") - pure (bigMapAbsense t) + pure (bigMapAbsense $ notesSing tns) proofContract <- maybe (typeCheckInstrErr uInstr (SomeHST inp) "UNPACK should not contain 'contract' type") - pure (contractTypeAbsense t) + pure (contractTypeAbsense $ notesSing tns) case (proofOp, proofBigMap, proofContract) of (Dict, Dict, Dict) -> - pure $ inp :/ UNPACK ::: ((STOption t, ns, vn) ::& rs) + pure $ inp :/ UNPACK ::: ((ns, vn) ::& rs) - (U.PACK vn, (a, _, _) ::& rs) -> do + (U.PACK vn, (a, _) ::& rs) -> do proofOp <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "Operations cannot appear in serialized data" - $ Left $ UnsupportedTypes [fromSingT a]) - pure (opAbsense a) + $ Left $ UnsupportedTypes [notesT a]) + pure (opAbsense $ notesSing a) proofBigMap <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "BigMap cannot appear in serialized data" - $ Left $ UnsupportedTypes [fromSingT a]) - pure (bigMapAbsense a) + $ Left $ UnsupportedTypes [notesT a]) + pure (bigMapAbsense $ notesSing a) case (proofOp, proofBigMap) of (Dict, Dict) -> - pure $ inp :/ PACK ::: ((STc SCBytes, starNotes, vn) ::& rs) + pure $ inp :/ PACK ::: ((starNotes, vn) ::& rs) - (U.CONCAT vn, (STc SCBytes, _, _) ::& (STc SCBytes, _, _) ::& _) -> + (U.CONCAT vn, (NTcs SCBytes, _) ::& (NTcs SCBytes, _) ::& _) -> concatImpl inp vn - (U.CONCAT vn, (STc SCString, _, _) ::& (STc SCString, _, _) ::& _) -> + (U.CONCAT vn, (NTcs SCString, _) ::& (NTcs SCString, _) ::& _) -> concatImpl inp vn - (U.CONCAT vn, (STList (STc SCBytes), _, _) ::& _) -> + (U.CONCAT vn, (STList (STc SCBytes), _, _) ::&+ _) -> concatImpl' inp vn - (U.CONCAT vn, (STList (STc SCString), _, _) ::& _) -> + (U.CONCAT vn, (STList (STc SCString), _, _) ::&+ _) -> concatImpl' inp vn - (U.SLICE vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& - (STc SCString, _, _) ::& _) -> sliceImpl inp vn - (U.SLICE vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& - (STc SCBytes, _, _) ::& _) -> sliceImpl inp vn + (U.SLICE vn, (NTcs SCNat, _) ::& + (NTcs SCNat, _) ::& + (NTcs SCString, _) ::& _) -> sliceImpl inp vn + (U.SLICE vn, (NTcs SCNat, _) ::& + (NTcs SCNat, _) ::& + (NTcs SCBytes, _) ::& _) -> sliceImpl inp vn - (U.ISNAT vn', (STc SCInt, _, oldVn) ::& rs) -> do + (U.ISNAT vn', (NTcs SCInt, oldVn) ::& rs) -> do let vn = vn' `orAnn` oldVn - pure $ inp :/ ISNAT ::: ((STOption (STc SCNat), starNotes, vn) ::& rs) + pure $ inp :/ ISNAT ::: ((starNotes, vn) ::& rs) - (U.ADD vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> addImpl a b inp vn - (U.SUB vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> subImpl a b inp vn - (U.MUL vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> mulImpl a b inp vn - (U.EDIV vn, (STc a, _, _) ::& (STc b, _, _) ::& _) -> edivImpl a b inp vn + (U.ADD vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> addImpl a b inp vn + (U.SUB vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> subImpl a b inp vn + (U.MUL vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> mulImpl a b inp vn + (U.EDIV vn, (STc a, _, _) ::&+ (STc b, _, _) ::&+ _) -> edivImpl a b inp vn - (U.ABS vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Abs ABS inp vn + (U.ABS vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Abs ABS inp vn - (U.NEG vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Neg NEG inp vn - (U.NEG vn, (STc SCNat, _, _) ::& _) -> unaryArithImpl @Neg NEG inp vn + (U.NEG vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn + (U.NEG vn, (STc SCNat, _, _) ::&+ _) -> unaryArithImpl @Neg NEG inp vn - (U.LSL vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @Lsl LSL inp vn + (U.LSL vn, (STc SCNat, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @Lsl LSL inp vn - (U.LSR vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @Lsr LSR inp vn + (U.LSR vn, (STc SCNat, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @Lsr LSR inp vn - (U.OR vn, (STc SCBool, _, _) ::& - (STc SCBool, _, _) ::& _) -> arithImpl @Or OR inp vn - (U.OR vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @Or OR inp vn + (U.OR vn, (STc SCBool, _, _) ::&+ + (STc SCBool, _, _) ::&+ _) -> arithImpl @Or OR inp vn + (U.OR vn, (STc SCNat, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @Or OR inp vn - (U.AND vn, (STc SCInt, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @And AND inp vn - (U.AND vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @And AND inp vn - (U.AND vn, (STc SCBool, _, _) ::& - (STc SCBool, _, _) ::& _) -> arithImpl @And AND inp vn + (U.AND vn, (STc SCInt, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @And AND inp vn + (U.AND vn, (STc SCNat, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @And AND inp vn + (U.AND vn, (STc SCBool, _, _) ::&+ + (STc SCBool, _, _) ::&+ _) -> arithImpl @And AND inp vn - (U.XOR vn, (STc SCBool, _, _) ::& - (STc SCBool, _, _) ::& _) -> arithImpl @Xor XOR inp vn - (U.XOR vn, (STc SCNat, _, _) ::& - (STc SCNat, _, _) ::& _) -> arithImpl @Xor XOR inp vn + (U.XOR vn, (STc SCBool, _, _) ::&+ + (STc SCBool, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn + (U.XOR vn, (STc SCNat, _, _) ::&+ + (STc SCNat, _, _) ::&+ _) -> arithImpl @Xor XOR inp vn - (U.NOT vn, (STc SCNat, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn - (U.NOT vn, (STc SCBool, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn - (U.NOT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Not NOT inp vn + (U.NOT vn, (STc SCNat, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn + (U.NOT vn, (STc SCBool, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn + (U.NOT vn, (STc SCInt, _, _) ::&+ _) -> unaryArithImpl @Not NOT inp vn (U.COMPARE vn, - (a :: Sing aT, an :: Notes aT, _) - ::& (_ :: Sing bT, bn :: Notes bT, _) + (an :: Notes aT, _) + ::& (bn :: Notes bT, _) ::& rs ) -> do @@ -659,11 +639,11 @@ maybe (onTypeCheckInstrErr (U.COMPARE vn) (SomeHST inp) "comparison is given incomparable arguments" $ Left $ UnsupportedTypes [demote @aT, demote @bT]) - pure (comparabilityPresence a) + pure (comparabilityPresence $ notesSing an) case proof of Dict -> do - pure $ inp :/ COMPARE ::: ((sing, starNotes, vn) ::& rs) + pure $ inp :/ COMPARE ::: ((starNotes, vn) ::& rs) Left err -> do typeCheckInstrErr' uInstr (SomeHST inp) "comparing different types:" err @@ -671,144 +651,145 @@ errConv :: (MonadReader InstrCallStack m, MonadError TCError m) => Either AnnConvergeError a -> m a errConv = onTypeCheckInstrAnnErr uInstr inp "comparing types with different annotations:" - (U.EQ vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Eq' EQ inp vn + (U.EQ vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Eq' EQ inp vn - (U.NEQ vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Neq NEQ inp vn + (U.NEQ vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Neq NEQ inp vn - (U.LT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Lt LT inp vn + (U.LT vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Lt LT inp vn - (U.GT vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Gt GT inp vn + (U.GT vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Gt GT inp vn - (U.LE vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Le LE inp vn + (U.LE vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Le LE inp vn - (U.GE vn, (STc SCInt, _, _) ::& _) -> unaryArithImpl @Ge GE inp vn + (U.GE vn, (NTcs SCInt, _) ::& _) -> unaryArithImpl @Ge GE inp vn - (U.INT vn, (STc SCNat, _, _) ::& rs) -> - pure $ inp :/ INT ::: ((STc SCInt, starNotes, vn) ::& rs) + (U.INT vn, (NTcs SCNat, _) ::& rs) -> + pure $ inp :/ INT ::: ((starNotes, vn) ::& rs) (U.SELF vn fn, _) -> do cpType <- gets tcContractParam let t = fromUType cpType -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has -- valid parameter type - withUType cpType $ \(singcp :: Sing cp, (ParamNotesUnsafe -> notescp)) -> do + withUType cpType $ \(ParamNotesUnsafe -> notescp :: ParamNotes t) -> do proofOp <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain operation" $ Left $ UnsupportedTypes [t]) - pure (opAbsense singcp) + pure (opAbsense $ sing @t) proofBigMap <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain nested big_map" $ Left $ UnsupportedTypes [t]) - pure (nestedBigMapsAbsense singcp) + pure (nestedBigMapsAbsense $ sing @t) case (proofOp, proofBigMap) of (Dict, Dict) -> do epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $ epNameFromRefAnn fn `onLeft` IllegalEntryPoint MkEntryPointCallRes (argNotes :: Notes arg) epc <- - mkEntryPointCall epName (singcp, notescp) + mkEntryPointCall epName notescp & maybeToRight (EntryPointNotFound epName) & onTypeCheckInstrErr uInstr (SomeHST inp) "entrypoint not found" let ntRes = NTContract U.noAnn argNotes pure $ inp :/ SELF @arg (SomeEpc epc) - ::: ((sing @('TContract arg), ntRes, vn) ::& inp) + ::: ((ntRes, vn) ::& inp) - (U.CONTRACT vn fn mt, (STc SCAddress, _, _) ::& rs) -> - withUType mt $ \(t :: Sing t, tns :: Notes t) -> do + (U.CONTRACT vn fn mt, (NTcs SCAddress, _) ::& rs) -> + withUType mt $ \(tns :: Notes t) -> do proofOp <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain operation" $ Left $ UnsupportedTypes [fromUType mt]) - pure (opAbsense t) + pure (opAbsense $ sing @t) proofBigMap <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain nested big_map" $ Left $ UnsupportedTypes [fromUType mt]) - pure (nestedBigMapsAbsense t) + pure (nestedBigMapsAbsense $ sing @t) let ns = NTOption def $ NTContract def tns epName <- onTypeCheckInstrErr uInstr (SomeHST inp) "Bad annotation:" $ epNameFromRefAnn fn `onLeft` IllegalEntryPoint case (proofOp, proofBigMap) of (Dict, Dict) -> - pure $ inp :/ CONTRACT tns epName ::: ((STOption $ STContract t, ns, vn) ::& rs) + pure $ inp :/ CONTRACT tns epName ::: ((ns, vn) ::& rs) - (U.TRANSFER_TOKENS vn, ((_ :: Sing p'), _, _) - ::& (STc SCMutez, _, _) ::& (STContract (p :: Sing p), _, _) ::& rs) -> do + (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _) + ::& (NTcs SCMutez, _) + ::& (STContract (p :: Sing p), _, _) ::&+ rs) -> do proofOp <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain operation" - $ Left $ UnsupportedTypes [demote @p]) + $ Left $ UnsupportedTypes [fromSingT p]) pure (opAbsense p) proofBigMap <- maybe (onTypeCheckInstrErr uInstr (SomeHST inp) "contract param type cannot contain big_map" - $ Left $ UnsupportedTypes [demote @p]) + $ Left $ UnsupportedTypes [fromSingT p]) pure (nestedBigMapsAbsense p) case (eqType @p @p', proofOp, proofBigMap) of (Right Refl, Dict, Dict) -> - pure $ inp :/ TRANSFER_TOKENS ::: ((STOperation, starNotes, vn) ::& rs) + pure $ inp :/ TRANSFER_TOKENS ::: ((starNotes, vn) ::& rs) (Left m, _, _) -> onTypeCheckInstrErr uInstr (SomeHST inp) "mismatch of contract param type:" (Left m) - (U.SET_DELEGATE vn, (STOption (STc SCKeyHash), _, _) ::& rs) -> do - pure $ inp :/ SET_DELEGATE ::: ((STOperation, starNotes, vn) ::& rs) + (U.SET_DELEGATE vn, (STOption (STc SCKeyHash), _, _) ::&+ rs) -> do + pure $ inp :/ SET_DELEGATE ::: ((starNotes, vn) ::& rs) (U.CREATE_CONTRACT ovn avn contract, (STOption (STc SCKeyHash), _, _) - ::& (STc SCMutez, _, _) - ::& ((_ :: Sing g), gn, _) ::& rs) -> do - (SomeContract (FullContract (contr :: Contract p' g') paramNotes storeNotes)) + ::&+ (NTcs SCMutez, _) + ::& (gn :: Notes g, _) ::& rs) -> do + (SomeContract (FullContract (contr :: ContractCode p' g') paramNotes storeNotes)) <- lift $ typeCheckContractImpl contract Refl <- checkEqT @g @g' uInstr inp "contract storage type mismatch" void $ onTypeCheckInstrAnnErr uInstr inp "contract storage type mismatch" (converge gn storeNotes) pure $ inp :/ CREATE_CONTRACT (FullContract contr paramNotes storeNotes) ::: - ((STOperation, starNotes, ovn) ::& (STc SCAddress, starNotes, avn) ::& rs) + ((starNotes, ovn) ::& (starNotes, avn) ::& rs) - (U.IMPLICIT_ACCOUNT vn, (STc SCKeyHash, _, _) ::& rs) -> - pure $ inp :/ IMPLICIT_ACCOUNT ::: ((STContract STUnit, starNotes, vn) ::& rs) + (U.IMPLICIT_ACCOUNT vn, (NTcs SCKeyHash, _) ::& rs) -> + pure $ inp :/ IMPLICIT_ACCOUNT ::: ((starNotes, vn) ::& rs) (U.NOW vn, _) -> - pure $ inp :/ NOW ::: ((STc SCTimestamp, starNotes, vn) ::& inp) + pure $ inp :/ NOW ::: ((starNotes, vn) ::& inp) (U.AMOUNT vn, _) -> - pure $ inp :/ AMOUNT ::: ((STc SCMutez, starNotes, vn) ::& inp) + pure $ inp :/ AMOUNT ::: ((starNotes, vn) ::& inp) (U.BALANCE vn, _) -> - pure $ inp :/ BALANCE ::: ((STc SCMutez, starNotes, vn) ::& inp) + pure $ inp :/ BALANCE ::: ((starNotes, vn) ::& inp) (U.CHECK_SIGNATURE vn, - (STKey, _, _) - ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs) -> - pure $ inp :/ CHECK_SIGNATURE ::: ((STc SCBool, starNotes, vn) ::& rs) + (NTKey _, _) + ::& (NTSignature _, _) ::& (NTcs SCBytes, _) ::& rs) -> + pure $ inp :/ CHECK_SIGNATURE ::: ((starNotes, vn) ::& rs) - (U.SHA256 vn, (STc SCBytes, _, _) ::& rs) -> - pure $ inp :/ SHA256 ::: ((STc SCBytes, starNotes, vn) ::& rs) + (U.SHA256 vn, (NTcs SCBytes, _) ::& rs) -> + pure $ inp :/ SHA256 ::: ((starNotes, vn) ::& rs) - (U.SHA512 vn, (STc SCBytes, _, _) ::& rs) -> - pure $ inp :/ SHA512 ::: ((STc SCBytes, starNotes, vn) ::& rs) + (U.SHA512 vn, (NTcs SCBytes, _) ::& rs) -> + pure $ inp :/ SHA512 ::: ((starNotes, vn) ::& rs) - (U.BLAKE2B vn, (STc SCBytes, _, _) ::& rs) -> - pure $ inp :/ BLAKE2B ::: ((STc SCBytes, starNotes, vn) ::& rs) + (U.BLAKE2B vn, (NTcs SCBytes, _) ::& rs) -> + pure $ inp :/ BLAKE2B ::: ((starNotes, vn) ::& rs) - (U.HASH_KEY vn, (STKey, _, _) ::& rs) -> - pure $ inp :/ HASH_KEY ::: ((STc SCKeyHash, starNotes, vn) ::& rs) + (U.HASH_KEY vn, (NTKey{}, _) ::& rs) -> + pure $ inp :/ HASH_KEY ::: ((starNotes, vn) ::& rs) (U.STEPS_TO_QUOTA vn, _) -> - pure $ inp :/ STEPS_TO_QUOTA ::: ((STc SCNat, starNotes, vn) ::& inp) + pure $ inp :/ STEPS_TO_QUOTA ::: ((starNotes, vn) ::& inp) (U.SOURCE vn, _) -> - pure $ inp :/ SOURCE ::: ((STc SCAddress, starNotes, vn) ::& inp) + pure $ inp :/ SOURCE ::: ((starNotes, vn) ::& inp) (U.SENDER vn, _) -> - pure $ inp :/ SENDER ::: ((STc SCAddress, starNotes, vn) ::& inp) + pure $ inp :/ SENDER ::: ((starNotes, vn) ::& inp) - (U.ADDRESS vn, (STContract _, _, _) ::& rs) -> - pure $ inp :/ ADDRESS ::: ((STc SCAddress, starNotes, vn) ::& rs) + (U.ADDRESS vn, (NTContract{}, _) ::& rs) -> + pure $ inp :/ ADDRESS ::: ((starNotes, vn) ::& rs) (U.CHAIN_ID vn, _) -> - pure $ inp :/ CHAIN_ID ::: ((STChainId, starNotes, vn) ::& inp) + pure $ inp :/ CHAIN_ID ::: ((starNotes, vn) ::& inp) _ -> typeCheckInstrErr uInstr (SomeHST inp) "unknown expression" @@ -859,17 +840,17 @@ -> [U.ExpandedOp] -> HST (c ': rs) -> (forall v' . (Typeable v', SingI v') => - Sing v' -> Notes v' -> HST rs -> HST (MapOpRes c v' ': rs)) + Notes v' -> HST rs -> HST (MapOpRes c v' ': rs)) -> TypeCheckInstr (SomeInstr (c ': rs)) mapImpl vn instr mp i@(_ ::& rs) mkRes = do - _ :/ subp <- lift $ typeCheckList mp ((sing, vn, def) ::& rs) + _ :/ subp <- lift $ typeCheckList mp ((vn, def) ::& rs) case subp of sub ::: subo -> case subo of - (b, bn, _bvn) ::& rs' -> do + (bn, _bvn) ::& rs' -> do Refl <- checkEqHST rs rs' instr i $ "map expression has changed not only top of the stack" - pure $ i :/ MAP sub ::: mkRes b bn rs' + pure $ i :/ MAP sub ::: mkRes bn rs' _ -> typeCheckInstrErr instr (SomeHST i) "map expression has wrong output stack type (empty stack)" AnyOutInstr _ -> typeCheckInstrErr instr (SomeHST i) "MAP code block always fails, which is not allowed" @@ -885,9 +866,9 @@ -> NonEmpty U.ExpandedOp -> HST (c ': rs) -> TypeCheckInstr (SomeInstr (c ': rs)) -iterImpl en instr mp i@((_, _, lvn) ::& rs) = do +iterImpl en instr mp i@((_, lvn) ::& rs) = do let evn = deriveVN "elt" lvn - _ :/ subp <- lift $ typeCheckNE mp ((sing, en, evn) ::& rs) + _ :/ subp <- lift $ typeCheckNE mp ((en, evn) ::& rs) case subp of subI ::: o -> do Refl <- checkEqHST o rs instr i @@ -904,21 +885,21 @@ => U.ExpandedInstr -> [U.ExpandedOp] -> VarAnn - -> Sing it -> Notes it - -> Sing ot -> Notes ot + -> Notes it + -> Notes ot -> HST ts -> TypeCheckInstr (SomeInstr ts) -lamImpl instr is vn it ins ot ons i = do +lamImpl instr is vn ins ons i = do when (any hasSelf is) $ typeCheckInstrErr instr (SomeHST i) "The SELF instruction cannot appear in a lambda" - _ :/ lamI <- lift $ typeCheckList is ((it, ins, def) ::& SNil) + _ :/ lamI <- lift $ typeCheckList is ((ins, def) ::& SNil) let lamNotes onsr = NTLambda def ins onsr - let lamSt onsr = (STLambda it ot, lamNotes onsr, vn) ::& i + let lamSt onsr = (lamNotes onsr, vn) ::& i fmap (i :/) $ case lamI of lam ::: lo -> do case eqHST1 @ot lo of Right Refl -> do - let (_, ons', _) ::& SNil = lo + let (ons', _) ::& SNil = lo onsr <- onTypeCheckInstrAnnErr instr i "wrong output type of lambda's expression:" (converge ons ons') pure (LAMBDA (VLam $ RfNormal lam) ::: lamSt onsr) Left m -> onTypeCheckInstrErr instr (SomeHST i) diff --git a/src/Michelson/TypeCheck/Types.hs b/src/Michelson/TypeCheck/Types.hs --- a/src/Michelson/TypeCheck/Types.hs +++ b/src/Michelson/TypeCheck/Types.hs @@ -1,12 +1,11 @@ module Michelson.TypeCheck.Types ( HST (..) , (-:&) + , pattern (::&+) , SomeHST (..) , SomeInstrOut (..) , SomeInstr (..) - , SomeNotedValue (..) , SomeContract (..) - , SomeCValue (..) , BoundVars (..) , TcExtFrames , mapSomeContract @@ -21,10 +20,9 @@ import Michelson.Untyped (Var, Type, noAnn) import Michelson.Untyped.Annotation (VarAnn) import Michelson.Typed - (Notes(..), Sing(..), T(..), fromSingT, starNotes) + (Notes(..), Sing(..), T(..), starNotes, notesT) import qualified Michelson.Typed as T import Michelson.Typed.Instr -import Michelson.Typed.Value import Util.Typeable -- | Data type holding type information for stack (Heterogeneous Stack Type). @@ -44,35 +42,37 @@ -- These applications of @Typeable@ class are required for convenient usage -- of type encoded by @HST ts@ with some functions from @Data.Typeable@. -- --- Data type @HST@ (Heterogeneous Stack Type) is a heterogenuous list of triples. --- First element of triple is a type singleton which is due to main motivation --- behind @HST@, namely for it to be used as representation of @Instr@ type --- data for pattern-matching. --- Second element of triple is a structure, holding field and type annotations +-- Data type @HST@ (Heterogeneous Stack Type) is a heterogenuous list of tuples. +-- First element of tuple is a structure, holding field and type annotations -- for a given type. --- Third element of triple is an optional variable annotation for the stack +-- Second element of tuple is an optional variable annotation for the stack -- element. +-- Additionally constructor keeps 'SingI' constraint for the current type. data HST (ts :: [T]) where SNil :: HST '[] (::&) :: (Typeable xs, Typeable x, SingI x) - => (Sing x, Notes x, VarAnn) + => (Notes x, VarAnn) -> HST xs -> HST (x ': xs) +instance NFData (HST ts) where + rnf (SNil) = () + rnf ((a, b) ::& hst) = rnf (a, b, hst) + instance Show (HST ts) where show SNil = "[]" show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]" where showDo :: HST (t ': ts_) -> String - showDo ((a, _notes, _vn) ::& (b ::& c)) = - show (fromSingT a) <> ", " <> showDo (b ::& c) - showDo ((a, _notes, _vn) ::& SNil) = show (fromSingT a) + showDo ((notesT -> t, _vn) ::& (b ::& c)) = + show t <> ", " <> showDo (b ::& c) + showDo ((notesT -> t, _vn) ::& SNil) = show t infixr 7 ::& instance Eq (HST ts) where SNil == SNil = True - (_, n1, a1) ::& h1 == (_, n2, a2) ::& h2 = + (n1, a1) ::& h1 == (n2, a2) ::& h2 = n1 == n2 && a1 == a2 && h1 == h2 -- | Append a type to 'HST', assuming that notes and annotations @@ -82,14 +82,29 @@ => Sing x -> HST xs -> HST (x ': xs) -s -:& hst = (s, starNotes, noAnn) ::& hst +_ -:& hst = (starNotes, noAnn) ::& hst infixr 7 -:& +-- | Extended pattern-match - adds @Sing x@ argument. +infixr 7 ::&+ +pattern (::&+) + :: () + => ( ys ~ (x ': xs) + , Typeable x, SingI x, Typeable xs + ) + => (Sing x, Notes x, VarAnn) + -> HST xs + -> HST ys +pattern x ::&+ hst <- ((\(n, v) -> (T.notesSing n, n, v)) -> x) ::& hst + where (_, n, v) ::&+ hst = (n, v) ::& hst + -- | No-argument type wrapper for @HST@ data type. data SomeHST where SomeHST :: Typeable ts => HST ts -> SomeHST deriving stock instance Show SomeHST +instance NFData SomeHST where + rnf (SomeHST h) = rnf h instance Eq SomeHST where SomeHST hst1 == SomeHST hst2 = hst1 `eqParam1` hst2 @@ -132,27 +147,11 @@ instance Show (ExtInstr inp) => Show (SomeInstr inp) where show (inp :/ out) = show inp <> " -> " <> show out --- | Data type, holding strictly-typed Michelson value along with its --- type singleton. -data SomeNotedValue where - (::::) :: (SingI t, Typeable t) - => T.Value t - -> (Sing t, Notes t) - -> SomeNotedValue - -instance Show SomeNotedValue where - show (val :::: (sing, notes)) = - show val <> " :: " <> "(" <> show (fromSingT sing) - <> ", " <> show notes <> ")" - --- | Data type, holding strictly-typed Michelson value along with its --- type singleton. -data SomeCValue where - (:--:) :: (SingI t, Typeable t) - => CValue t -> Sing t -> SomeCValue - data SomeContract where SomeContract :: FullContract cp st -> SomeContract + +instance NFData SomeContract where + rnf (SomeContract c) = rnf c mapSomeContract :: (forall inp out. Instr inp out -> Instr inp out) diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs --- a/src/Michelson/TypeCheck/Value.hs +++ b/src/Michelson/TypeCheck/Value.hs @@ -8,7 +8,7 @@ import Data.Default (def) import qualified Data.Map as M import qualified Data.Set as S -import Data.Singletons (SingI(..)) +import Data.Singletons (SingI(..), demote) import Data.Typeable ((:~:)(..)) import Prelude hiding (EQ, GT, LT) @@ -18,8 +18,8 @@ import Michelson.TypeCheck.TypeCheck (TcInstrHandler, TypeCheckEnv(..), TypeCheckInstr) import Michelson.TypeCheck.Types import Michelson.Typed - (pattern AsUType, CT(..), CValue(..), EpAddress(..), Notes(..), ParamNotes(..), Sing(..), - Value'(..), converge, fromSingCT, fromSingT, starNotes) + (pattern AsUTypeExt, CValue(..), EpAddress(..), Notes(..), Sing(..), Value'(..), fromSingCT, + fromSingT, starNotes) import qualified Michelson.Typed as T import qualified Michelson.Untyped as U import Tezos.Address (Address(..)) @@ -27,46 +27,42 @@ import Tezos.Crypto (parseKeyHash, parsePublicKey, parseSignature) typeCheckCValue - :: U.Value' op -> CT -> Either (U.Value' op, TCTypeError) SomeCValue + :: forall op ct + . U.Value' op -> Sing ct -> Either (U.Value' op, TCTypeError) (CValue ct) typeCheckCValue val ct = case (val, ct) of - (U.ValueInt i, CInt) -> pure $ CvInt i :--: SCInt - (U.ValueInt i, CNat) - | i >= 0 -> pure $ CvNat (fromInteger i) :--: SCNat + (U.ValueInt i, SCInt) -> pure $ CvInt i + (U.ValueInt i, SCNat) + | i >= 0 -> pure $ CvNat (fromInteger i) | otherwise -> Left (U.ValueInt i, NegativeNat) - (v@(U.ValueInt i), CMutez) -> do + (v@(U.ValueInt i), SCMutez) -> do mtz <- maybeToRight (v, InvalidTimestamp) . mkMutez $ fromInteger i - pure $ CvMutez mtz :--: SCMutez - (U.ValueString s, CString) -> - pure $ CvString s :--: SCString - (v@(U.ValueString s), CAddress) -> do + pure $ CvMutez mtz + (U.ValueString s, SCString) -> + pure $ CvString s + (v@(U.ValueString s), SCAddress) -> do addr <- T.parseEpAddress (unMText s) `onLeft` ((v, ) . InvalidAddress) - pure $ CvAddress addr :--: SCAddress - (v@(U.ValueString s), CKeyHash) -> do + pure $ CvAddress addr + (v@(U.ValueString s), SCKeyHash) -> do kHash <- parseKeyHash (unMText s) `onLeft` ((v, ) . InvalidKeyHash) - pure $ CvKeyHash kHash :--: SCKeyHash - (v@(U.ValueString s), CTimestamp) -> do + pure $ CvKeyHash kHash + (v@(U.ValueString s), SCTimestamp) -> do tstamp <- maybeToRight (v, InvalidTimestamp) . parseTimestamp $ unMText s - pure $ CvTimestamp tstamp :--: SCTimestamp - (U.ValueInt i, CTimestamp) -> - pure $ CvTimestamp (timestampFromSeconds i) :--: SCTimestamp - (U.ValueBytes (U.InternalByteString s), CBytes) -> - pure $ CvBytes s :--: SCBytes - (U.ValueTrue, CBool) -> pure $ CvBool True :--: SCBool - (U.ValueFalse, CBool) -> pure $ CvBool False :--: SCBool + pure $ CvTimestamp tstamp + (U.ValueInt i, SCTimestamp) -> + pure $ CvTimestamp (timestampFromSeconds i) + (U.ValueBytes (U.InternalByteString s), SCBytes) -> + pure $ CvBytes s + (U.ValueTrue, SCBool) -> pure $ CvBool True + (U.ValueFalse, SCBool) -> pure $ CvBool False (v, t) -> - Left $ (v, InvalidValueType (T.Tc t)) + Left $ (v, InvalidValueType $ T.Tc $ fromSingCT t) typeCheckCVals - :: forall t op . (Typeable t, SingI t) - => [U.Value' op] - -> CT + :: forall t op + . [U.Value' op] + -> Sing t -> Either (U.Value' op, TCTypeError) [CValue t] -typeCheckCVals mvs t = traverse check mvs - where - check mv = do - v :--: (_ :: Sing t') <- typeCheckCValue mv t - Refl <- eqType @('T.Tc t) @('T.Tc t') `onLeft` (,) mv - pure v +typeCheckCVals mvs t = traverse (`typeCheckCValue` t) mvs tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a tcFailedOnValue v t msg err = do @@ -77,7 +73,7 @@ -- given in representation from @Michelson.Type@ module to representation -- in strictly typed GADT. -- --- As a third argument, @typeCheckValImpl@ accepts expected type of value. +-- @typeCheckValImpl@ is polymorphic in the expected type of value. -- -- Type checking algorithm pattern-matches on parse value representation, -- expected type @t@ and constructs @Val t@ value. @@ -86,35 +82,36 @@ -- that is interpreted as input of wrong type and type check finishes with -- error. typeCheckValImpl - :: TcInstrHandler + :: forall ty. + SingI ty + => TcInstrHandler -> U.Value - -> (Sing t, Notes t) - -> TypeCheckInstr SomeNotedValue -typeCheckValImpl tcDo uvalue ty@(tySing, tyNotes) = case (uvalue, tySing, tyNotes) of - (mv, t@(STc ct), NTc nt) -> do - case typeCheckCValue mv (fromSingCT ct) of - Left (uval, err) -> tcFailedOnValue uval (fromSingT $ t) "" (Just err) - Right (v :--: cst) -> pure $ VC v :::: (STc cst, NTc nt) - (U.ValueString (parsePublicKey . unMText -> Right s), STKey, _) -> - pure $ T.VKey s :::: ty + -> TypeCheckInstr (T.Value ty) +typeCheckValImpl tcDo uvalue = case (uvalue, sing @ty) of + (mv, t@(STc ct)) -> do + case typeCheckCValue mv ct of + Left (uval, err) -> tcFailedOnValue uval (fromSingT t) "" (Just err) + Right v -> pure $ VC v + (U.ValueString (parsePublicKey . unMText -> Right s), STKey) -> + pure $ T.VKey s - (U.ValueString (parseSignature . unMText -> Right s), STSignature, _) -> - pure $ VSignature s :::: ty + (U.ValueString (parseSignature . unMText -> Right s), STSignature) -> + pure $ VSignature s - (U.ValueString (parseChainId . unMText -> Right ci), STChainId, _) -> - pure $ VChainId ci :::: ty - (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId, _) -> - pure $ VChainId ci :::: ty + (U.ValueString (parseChainId . unMText -> Right ci), STChainId) -> + pure $ VChainId ci + (U.ValueBytes (mkChainId . U.unInternalByteString -> Just ci), STChainId) -> + pure $ VChainId ci ( cv@(U.ValueString (T.parseEpAddress . unMText -> Right epAddr)), - STContract (pc :: Sing cp), NTContract _ pn ) -> do + STContract (pc :: Sing cp)) -> do instrPos <- ask contracts <- gets tcContracts - let ensureTypeMatches :: (Typeable t, SingI t) => (Sing t, Notes t) -> TypeCheckInstr (cp :~: t) - ensureTypeMatches (_, pn') = + let ensureTypeMatches :: forall t'. (Typeable t', SingI t') => TypeCheckInstr (cp :~: t') + ensureTypeMatches = liftEither @_ @TypeCheckInstr $ - first (TCFailedOnValue cv (fromSingT tySing) "wrong contract parameter" instrPos . Just) $ - fmap fst $ matchTypes pn pn' + first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $ + eqType @cp @t' let unsupportedType :: Text -> Either TCError a unsupportedType desc = Left $ @@ -123,97 +120,94 @@ let EpAddress addr epName = epAddr case addr of KeyAddress _ -> do - Refl <- ensureTypeMatches (second unParamNotes T.tyImplicitAccountParam) - pure $ VContract addr T.sepcPrimitive :::: ty + Refl <- ensureTypeMatches @'T.TUnit + pure $ VContract addr T.sepcPrimitive ContractAddress ca -> case M.lookup ca contracts of -- Wrapping into 'ParamNotesUnsafe' is safe because originated contract has -- valid parameter type - Just (AsUType cpSing (T.ParamNotesUnsafe -> cpNotes)) -> do + Just (AsUTypeExt cpSing (T.ParamNotesUnsafe -> cpNotes)) -> do Dict <- liftEither $ maybe (unsupportedType "Operation") pure (T.opAbsense cpSing) Dict <- liftEither $ maybe (unsupportedType "Nested BigMaps") pure (T.nestedBigMapsAbsense cpSing) - case T.mkEntryPointCall epName (cpSing, cpNotes) of + case T.mkEntryPointCall epName cpNotes of Nothing -> throwError $ - TCFailedOnValue cv (fromSingT tySing) "unknown entrypoint" instrPos . Just $ + TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $ EntryPointNotFound epName - Just (T.MkEntryPointCallRes argNotes epc) -> do - ensureTypeMatches (sing, argNotes) - pure $ VContract addr (T.SomeEpc epc) :::: (sing, NTContract U.noAnn argNotes) + Just (T.MkEntryPointCallRes (_ :: Notes t') epc) -> do + Refl <- ensureTypeMatches @t' + pure $ VContract addr (T.SomeEpc epc) Nothing -> - throwError $ TCFailedOnValue cv (fromSingT tySing) "Contract literal unknown" + throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown" instrPos (Just $ UnknownContract addr) - (U.ValueUnit, STUnit, _) -> pure $ VUnit :::: ty - (U.ValuePair ml mr, STPair lt rt, NTPair n1 n2 n3 nl nr) -> do - l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl) - r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr) - pure $ VPair (l, r) :::: (STPair lst rst, NTPair n1 n2 n3 ln rn) - (U.ValueLeft ml, STOr lt rt, NTOr n1 n2 n3 nl nr) -> do - l :::: (lst, ln) <- typeCheckValImpl tcDo ml (lt, nl) - pure $ VOr (Left l) :::: ( STOr lst rt, NTOr n1 n2 n3 ln nr) - (U.ValueRight mr, STOr lt rt, NTOr n1 n2 n3 nl nr) -> do - r :::: (rst, rn) <- typeCheckValImpl tcDo mr (rt, nr) - pure $ VOr (Right r) :::: ( STOr lt rst, NTOr n1 n2 n3 nl rn) - (U.ValueSome mv, STOption vt, NTOption na nt) -> do - v :::: (vst, vns) <- typeCheckValImpl tcDo mv (vt, nt) - pure $ VOption (Just v) :::: (STOption vst, NTOption na vns) - (U.ValueNone, STOption _, _) -> do - pure $ VOption Nothing :::: ty + (U.ValueUnit, STUnit) -> pure $ VUnit + (U.ValuePair ml mr, STPair _ _) -> do + l <- typeCheckValImpl tcDo ml + r <- typeCheckValImpl tcDo mr + pure $ VPair (l, r) + (U.ValueLeft ml, STOr{}) -> do + l <- typeCheckValImpl tcDo ml + pure $ VOr (Left l) + (U.ValueRight mr, STOr{}) -> do + r <- typeCheckValImpl tcDo mr + pure $ VOr (Right r) + (U.ValueSome mv, STOption{}) -> do + v <- typeCheckValImpl tcDo mv + pure $ VOption (Just v) + (U.ValueNone, STOption _) -> do + pure $ VOption Nothing - (U.ValueNil, STList _, _) -> - pure $ T.VList [] :::: ty + (U.ValueNil, STList _) -> + pure $ T.VList [] - (U.ValueSeq (toList -> mels), STList vt, NTList _ x) -> do - (els, _) <- typeCheckValsImpl tcDo mels (vt, x) - pure $ VList els :::: ty + (U.ValueSeq (toList -> mels), STList _) -> do + els <- typeCheckValsImpl tcDo mels + pure $ VList els - (U.ValueNil, STSet _, _) -> - pure $ T.VSet S.empty :::: ty + (U.ValueNil, STSet _) -> + pure $ T.VSet S.empty - (sq@(U.ValueSeq (toList -> mels)), STSet vt, _) -> do + (sq@(U.ValueSeq (toList -> mels)), STSet vt) -> do instrPos <- ask - els <- liftEither $ typeCheckCVals mels (fromSingCT vt) + els <- liftEither $ typeCheckCVals mels vt `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc vt) "wrong type of set element:" instrPos (Just err) elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc vt) msg instrPos Nothing - pure $ VSet elsS :::: ty + pure $ VSet elsS - (U.ValueNil, STMap _ _, _) -> pure $ T.VMap M.empty :::: ty + (U.ValueNil, STMap _ _) -> pure $ T.VMap M.empty - (sq@(U.ValueMap (toList -> mels)), STMap kt vt, NTMap _ _ vn) -> do - keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt - pure $ VMap (M.fromDistinctAscList keyOrderedElts) :::: ty + (sq@(U.ValueMap (toList -> mels)), STMap kt _) -> do + keyOrderedElts <- typeCheckMapVal tcDo mels sq kt + pure $ VMap (M.fromDistinctAscList keyOrderedElts) - (U.ValueNil, STBigMap _ _ , _) -> - pure $ T.VBigMap M.empty :::: ty + (U.ValueNil, STBigMap _ _) -> + pure $ T.VBigMap M.empty - (sq@(U.ValueMap (toList -> mels)), STBigMap kt vt, NTBigMap _ _ vn) -> do - keyOrderedElts <- typeCheckMapVal tcDo mels sq vn kt vt - pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) :::: ty + (sq@(U.ValueMap (toList -> mels)), STBigMap kt _) -> do + keyOrderedElts <- typeCheckMapVal tcDo mels sq kt + pure $ VBigMap (M.fromDistinctAscList keyOrderedElts) - (v, STLambda (it :: Sing it) (ot :: Sing ot), NTLambda vn _ _) -> do + (v, STLambda (_ :: Sing it) (_ :: Sing ot)) -> do mp <- case v of U.ValueNil -> pure [] U.ValueLambda mp -> pure $ toList mp - _ -> tcFailedOnValue v (fromSingT tySing) "unexpected value" Nothing - li :/ instr <- typeCheckImpl tcDo mp ((it, starNotes, def) ::& SNil) - let (_, ins, _) ::& SNil = li - let lamS = STLambda it ot + _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing + _ :/ instr <- typeCheckImpl tcDo mp ((starNotes @it, def) ::& SNil) case instr of lam ::: (lo :: HST lo) -> do case eqHST1 @ot lo of Right Refl -> do - let (_, ons, _) ::& SNil = lo - pure $ VLam (T.RfNormal lam) :::: (STLambda it ot, NTLambda vn ins ons) + pure $ VLam (T.RfNormal lam) Left m -> - tcFailedOnValue v (fromSingT tySing) + tcFailedOnValue v (demote @ty) "wrong output type of lambda's value:" (Just m) AnyOutInstr lam -> - pure $ VLam (T.RfAlwaysFails lam) :::: (lamS, NTLambda def ins starNotes) + pure $ VLam (T.RfAlwaysFails lam) - (v, t, _) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing + (v, t) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing -- | Function @typeCheckMapVal@ typechecks given list of @Elt@s and -- ensures, that its keys are in ascending order. @@ -221,38 +215,31 @@ -- It return list of pairs (key, value) with keys in ascending order -- so it is safe to call @fromDistinctAscList@ on returned list typeCheckMapVal - :: (SingI kt, Typeable kt, SingI vt, Typeable vt) + :: (SingI kt, Typeable kt, SingI vt) => TcInstrHandler -> [U.Elt U.ExpandedOp] -> U.Value - -> Notes vt -> Sing kt - -> Sing vt -> TypeCheckInstr [(CValue kt, T.Value vt)] -typeCheckMapVal tcDo mels sq vn kt vt = do +typeCheckMapVal tcDo mels sq kt = do instrPos <- ask - ks <- liftEither $ typeCheckCVals (map (\(U.Elt k _) -> k) mels) (fromSingCT kt) + ks <- liftEither $ typeCheckCVals (map (\(U.Elt k _) -> k) mels) kt `onLeft` \(cv, err) -> TCFailedOnValue cv (fromSingT $ STc kt) "wrong type of map key:" instrPos (Just err) - (vals, _) <- typeCheckValsImpl tcDo (map (\(U.Elt _ v) -> v) mels) (vt, vn) + vals <- typeCheckValsImpl tcDo (map (\(U.Elt _ v) -> v) mels) ksS <- liftEither $ ensureDistinctAsc id ks `onLeft` \msg -> TCFailedOnValue sq (fromSingT $ STc kt) msg instrPos Nothing pure $ zip ksS vals typeCheckValsImpl - :: forall t . (Typeable t, SingI t) + :: forall t . (SingI t) => TcInstrHandler -> [U.Value] - -> (Sing t, Notes t) - -> TypeCheckInstr ([T.Value t], Notes t) -typeCheckValsImpl tcDo mvs (t, nt) = - fmap (first reverse) $ foldM check ([], nt) mvs + -> TypeCheckInstr [T.Value t] +typeCheckValsImpl tcDo mvs = + fmap reverse $ foldM check [] mvs where - check (res, ns) mv = do - instrPos <- ask - v :::: ((_ :: Sing t'), vns) <- typeCheckValImpl tcDo mv (t, nt) - Refl <- liftEither $ eqType @t @t' `onLeft` - (TCFailedOnValue mv (fromSingT t) "wrong element type" instrPos . Just) - ns' <- liftEither $ converge ns vns `onLeft` - ((TCFailedOnValue mv (fromSingT t) "wrong element type") instrPos . Just . AnnError) - pure (v : res, ns') + check :: [T.Value t] -> U.Value -> TypeCheckInstr [T.Value t] + check res mv = do + v <- typeCheckValImpl @t tcDo mv + pure (v : res) diff --git a/src/Michelson/Typed/Annotation.hs b/src/Michelson/Typed/Annotation.hs --- a/src/Michelson/Typed/Annotation.hs +++ b/src/Michelson/Typed/Annotation.hs @@ -22,16 +22,25 @@ , orAnn , isStar , starNotes + , notesSing + , notesT + , pattern NTcs ) where import Data.Default (Default(..)) import qualified Data.Kind as Kind import Data.Singletons (SingI(..)) import Fmt (Buildable(..), (+|), (|+)) +import Text.PrettyPrint.Leijen.Text (Doc, (<+>)) +import qualified Text.Show +import Michelson.Printer.Util + (RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, printDocS) import Michelson.Typed.Sing import Michelson.Typed.T (T(..)) -import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, noAnn, unifyAnn) +import Michelson.Untyped.Annotation + (Annotation, FieldAnn, TypeAnn, fullAnnSet, noAnn, singleAnnSet, unifyAnn) +import Util.TH import Util.Typeable -- | Data type, holding annotation data for a given Michelson type @t@. @@ -58,9 +67,61 @@ NTMap :: TypeAnn -> TypeAnn -> Notes v -> Notes ('TMap k v) NTBigMap :: TypeAnn -> TypeAnn -> Notes v -> Notes ('TBigMap k v) -deriving stock instance Show (Notes t) deriving stock instance Eq (Notes t) +$(deriveGADTNFData ''Notes) + +instance Show (Notes t) where + show = printDocS True . renderDoc doesntNeedParens + +instance Buildable (Notes t) where + build = buildRenderDoc + +instance RenderDoc (Notes t) where + renderDoc pn n = addParens pn $ case n of + NTc ta -> "NTc" <+> rendT ta + NTKey ta -> "NTKey" <+> rendT ta + NTUnit ta -> "NTUnit" <+> rendT ta + NTSignature ta -> "NTSignature" <+> rendT ta + NTChainId ta -> "NTChainId" <+> rendT ta + NTOption ta nt -> "NTOption" <+> rendT ta <+> rendN nt + NTList ta nt -> "NTList" <+> rendT ta <+> rendN nt + NTSet ta1 ta2 -> "NTSet" <+> rendT2 ta1 ta2 + NTOperation ta -> "NTOperation" <+> rendT ta + NTContract ta nt -> "NTContract" <+> rendT ta <+> rendN nt + NTPair ta fa1 fa2 np nq -> "NTPair" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq + NTOr ta fa1 fa2 np nq -> "NTOr" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq + NTLambda ta np nq -> "NTLambda" <+> rendT ta <+> rendN np <+> rendN nq + NTMap ta1 ta2 nv -> "NTMap" <+> rendT2 ta1 ta2 <+> rendN nv + NTBigMap ta1 ta2 nv -> "NTBigMap" <+> rendT2 ta1 ta2 <+> rendN nv + where + rendN :: Notes n -> Doc + rendN = renderDoc needsParens + + rendT :: TypeAnn -> Doc + rendT = renderDoc doesntNeedParens . singleAnnSet + + rendT2 :: TypeAnn -> TypeAnn -> Doc + rendT2 t1 t2 = renderDoc doesntNeedParens $ fullAnnSet [t1, t2] [] [] + + rendTF2 :: TypeAnn -> FieldAnn -> FieldAnn -> Doc + rendTF2 t f1 f2 = renderDoc doesntNeedParens $ fullAnnSet [t] [f1, f2] [] + +-- | Forget information about annotations, pick singleton with the same type. +-- +-- Note: currently we cannot derive 'Sing' from 'Notes' without 'SingI' because +-- for comparable types notes do not remember which exact comparable was used. +notesSing :: SingI t => Notes t -> Sing t +notesSing _ = sing + +-- | Get term-level type of notes. +notesT :: SingI t => Notes t -> T +notesT = fromSingT . notesSing + +-- | Similar to 'NTc' pattern, but gives singleton of the comparable type. +pattern NTcs :: SingI t => (t ~ 'Tc ct) => Sing ct -> Notes t +pattern NTcs s <- (notesSing -> STc s) + -- | In memory of `NStar` constructor. -- Generates notes with no annotations. starNotes :: forall t. SingI t => Notes t @@ -146,3 +207,6 @@ => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag) convergeAnns a b = maybe (Left $ AnnConvergeError a b) pure $ unifyAnn a b + +$(deriveGADTNFData ''AnnConvergeError) + diff --git a/src/Michelson/Typed/Arith.hs b/src/Michelson/Typed/Arith.hs --- a/src/Michelson/Typed/Arith.hs +++ b/src/Michelson/Typed/Arith.hs @@ -29,7 +29,7 @@ , compareOp ) where -import Data.Bits (complement, shift, xor, (.&.), (.|.)) +import Data.Bits (complement, shift, (.&.), (.|.)) import Data.Singletons (SingI(..)) import Fmt (Buildable(build)) @@ -64,14 +64,18 @@ | SubUnderflow | LslOverflow | LsrUnderflow - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) +instance NFData ArithErrorType + -- | Represents an arithmetic error of the operation. data ArithError n m = MutezArithError ArithErrorType n m | ShiftArithError ArithErrorType n m - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) +instance (NFData n, NFData m) => NFData (ArithError n m) + -- | Marker data type for add operation. class UnaryArithOp aop (n :: CT) where type UnaryArithRes aop n :: CT @@ -192,8 +196,8 @@ evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i .|. j) instance ArithOp And 'CInt 'CNat where - type ArithRes And 'CInt 'CNat = 'CInt - evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i .&. fromIntegral j) + type ArithRes And 'CInt 'CNat = 'CNat + evalOp _ (CvInt i) (CvNat j) = Right $ CvNat ((fromInteger i) .&. j) instance ArithOp And 'CNat 'CNat where type ArithRes And 'CNat 'CNat = 'CNat evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i .&. j) diff --git a/src/Michelson/Typed/CValue.hs b/src/Michelson/Typed/CValue.hs --- a/src/Michelson/Typed/CValue.hs +++ b/src/Michelson/Typed/CValue.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} -- | Module, containing CValue data type -- which represents Michelson comparable values. @@ -10,6 +11,7 @@ import Michelson.Typed.T (CT(..)) import Tezos.Core (Mutez, Timestamp) import Tezos.Crypto (KeyHash) +import Util.TH -- | Representation of comparable value -- in Michelson language. @@ -21,7 +23,7 @@ -- Only these values can be used as map keys -- or set elements. data CValue t where - CvInt :: Integer -> CValue 'CInt + CvInt :: Integer -> CValue 'CInt CvNat :: Natural -> CValue 'CNat CvString :: MText -> CValue 'CString CvBytes :: ByteString -> CValue 'CBytes @@ -34,3 +36,5 @@ deriving stock instance Show (CValue t) deriving stock instance Eq (CValue t) deriving stock instance Ord (CValue t) + +$(deriveGADTNFData ''CValue) diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs --- a/src/Michelson/Typed/Convert.hs +++ b/src/Michelson/Typed/Convert.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Michelson.Typed.Convert - ( convertContract + ( convertContractCode , convertFullContract , instrToOps , untypeValue @@ -27,10 +27,10 @@ import Util.Peano import Util.Typeable -convertContract +convertContractCode :: forall param store . (SingI param, SingI store) - => Contract param store -> U.Contract -convertContract contract = + => ContractCode param store -> U.Contract +convertContractCode contract = U.Contract { para = untypeDemoteT @param , stor = untypeDemoteT @store @@ -44,9 +44,9 @@ :: forall param store . (SingI param, SingI store) => FullContract param store -> U.Contract convertFullContract fc = - let c = convertContract (fcCode fc) - in c { U.para = mkUType sing (fcParamNotes fc) - , U.stor = mkUType sing (fcStoreNotes fc) } + let c = convertContractCode (fcCode fc) + in c { U.para = mkUType (fcParamNotes fc) + , U.stor = mkUType (fcStoreNotes fc) } -- | Convert a typed 'Val' to an untyped 'Value'. -- @@ -161,37 +161,37 @@ handleInstrAnnotate :: forall inp' out' . HasCallStack => Instr inp' out' -> PackedNotes out' -> U.ExpandedInstr - handleInstrAnnotate ins' (PackedNotes notes' sing') = let - x = handleInstr ins' in addInstrNote x sing' notes' + handleInstrAnnotate ins' (PackedNotes notes') = let + x = handleInstr ins' in addInstrNote x notes' where addInstrNote - :: HasCallStack - => U.ExpandedInstr -> Sing t -> Notes t -> U.ExpandedInstr - addInstrNote ins s nte = case (s, ins, nte) of - (_, U.PUSH va _ v, _) -> U.PUSH va (mkUType s nte) v + :: forall t. (SingI t, HasCallStack) + => U.ExpandedInstr -> Notes t -> U.ExpandedInstr + addInstrNote ins nte = case (sing @t, ins, nte) of + (_, U.PUSH va _ v, _) -> U.PUSH va (mkUType nte) v (_, U.SOME _ va, NTOption ta _) -> U.SOME ta va - (STOption sp, U.NONE _ va _, NTOption ta nt) -> U.NONE ta va (mkUType sp nt) + (STOption _, U.NONE _ va _, NTOption ta nt) -> U.NONE ta va (mkUType nt) (_, U.UNIT _ va, NTUnit ta) -> U.UNIT ta va (_, U.PAIR _ va _ _, NTPair ta f1 f2 _ _) -> U.PAIR ta va f1 f2 (_, U.CAR va f1, _) -> U.CAR va f1 (_, U.CDR va f1, _) -> U.CDR va f1 - (STOr _ sq, U.LEFT _ va _ _ _, NTOr ta f1 f2 _ n2) -> - U.LEFT ta va f1 f2 (mkUType sq n2) - (STOr sp _, U.RIGHT _ va _ _ _, NTOr ta f1 f2 n1 _) -> - U.RIGHT ta va f1 f2 (mkUType sp n1) - (STList sp, U.NIL _ va _, NTList ta n) -> U.NIL ta va (mkUType sp n) + (STOr _ _, U.LEFT _ va _ _ _, NTOr ta f1 f2 _ n2) -> + U.LEFT ta va f1 f2 (mkUType n2) + (STOr _ _, U.RIGHT _ va _ _ _, NTOr ta f1 f2 n1 _) -> + U.RIGHT ta va f1 f2 (mkUType n1) + (STList _, U.NIL _ va _, NTList ta n) -> U.NIL ta va (mkUType n) (_, U.EMPTY_SET _ va ct, NTSet ta1 ta2) -> U.EMPTY_SET ta1 va (addCtNote ta2 ct) - (STMap _ sq, U.EMPTY_MAP _ va ct _, NTMap ta1 ta2 n) -> - U.EMPTY_MAP ta1 va (addCtNote ta2 ct) (mkUType sq n) - (STBigMap _ sq, U.EMPTY_BIG_MAP _ va ct _, NTBigMap ta1 ta2 n) -> - U.EMPTY_BIG_MAP ta1 va (addCtNote ta2 ct) (mkUType sq n) - (STLambda sp sq, U.LAMBDA va _ _ ops, NTLambda _ n1 n2) -> - U.LAMBDA va (mkUType sp n1) (mkUType sq n2) ops - (_, U.CAST va _, n) -> U.CAST va (mkUType s n) - (STOption sp, U.UNPACK _ va _, NTOption ta nt) -> U.UNPACK ta va (mkUType sp nt) - (STOption (STContract sp), U.CONTRACT va fa _, NTOption _ (NTContract _ nt)) -> - U.CONTRACT va fa (mkUType sp nt) + (STMap _ _, U.EMPTY_MAP _ va ct _, NTMap ta1 ta2 n) -> + U.EMPTY_MAP ta1 va (addCtNote ta2 ct) (mkUType n) + (STBigMap _ _, U.EMPTY_BIG_MAP _ va ct _, NTBigMap ta1 ta2 n) -> + U.EMPTY_BIG_MAP ta1 va (addCtNote ta2 ct) (mkUType n) + (STLambda _ _, U.LAMBDA va _ _ ops, NTLambda _ n1 n2) -> + U.LAMBDA va (mkUType n1) (mkUType n2) ops + (_, U.CAST va _, n) -> U.CAST va (mkUType n) + (STOption _, U.UNPACK _ va _, NTOption ta nt) -> U.UNPACK ta va (mkUType nt) + (STOption (STContract _), U.CONTRACT va fa _, NTOption _ (NTContract _ nt)) -> + U.CONTRACT va fa (mkUType nt) (_, U.CONTRACT va fa t, NTOption _ _) -> U.CONTRACT va fa t (_, a@(U.APPLY {}), _) -> a (_, a@(U.CHAIN_ID {}), _) -> a @@ -446,7 +446,7 @@ i@(CONTRACT nt epName) | _ :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s) <- i -> let fa = epNameToRefAnn epName - in U.CONTRACT U.noAnn fa (mkUType (sing @p) nt) + in U.CONTRACT U.noAnn fa (mkUType nt) TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn SET_DELEGATE -> U.SET_DELEGATE U.noAnn i@(CREATE_CONTRACT fullContract) diff --git a/src/Michelson/Typed/Doc.hs b/src/Michelson/Typed/Doc.hs --- a/src/Michelson/Typed/Doc.hs +++ b/src/Michelson/Typed/Doc.hs @@ -1,8 +1,11 @@ -- | Extracting documentation from instructions set. module Michelson.Typed.Doc ( buildInstrDoc + , buildInstrDocWithGitRev , modifyInstrDoc + , modifyInstrAllDoc , cutInstrNonDoc + , docInstr ) where import Control.Lens (at) @@ -41,6 +44,20 @@ Just () -> pass Nothing -> someDocItemToContractDoc (SomeDocItem dep) +-- | Put a document item. +docInstr :: DocItem di => di -> Instr s s +docInstr = Ext . DOC_ITEM . SomeDocItem + +attachGitInfo :: DGitRevision -> Instr inp out -> Instr inp out +attachGitInfo gitRev = modifyInstrDoc $ \case + DGitRevisionUnknown -> Just gitRev + _ -> Nothing + +-- | Assemble contract documentation with the revision of the contract. +buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc +buildInstrDocWithGitRev gitRev contract = + buildInstrDoc $ attachGitInfo gitRev contract + -- | Assemble contract documentation. buildInstrDoc :: Instr inp out -> ContractDoc buildInstrDoc = dfsFoldInstr dfsSettings $ \case @@ -75,14 +92,19 @@ -- | Recursevly traverse an instruction and modify documentation items -- matching given type. +-- +-- If mapper returns 'Nothing', doc item will remain unmodified. modifyInstrDoc - :: DocItem i - => (i -> i) + :: (DocItem i1, DocItem i2) + => (i1 -> Maybe i2) -> Instr inp out -> Instr inp out modifyInstrDoc mapper = modifyInstrAllDoc untypedMapper where - untypedMapper sdi@(SomeDocItem di) = maybe sdi (SomeDocItem . mapper) (cast di) + untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do + di' <- cast di + newDi <- mapper di' + return (SomeDocItem newDi) -- | Leave only instructions related to documentation. -- diff --git a/src/Michelson/Typed/EntryPoints.hs b/src/Michelson/Typed/EntryPoints.hs --- a/src/Michelson/Typed/EntryPoints.hs +++ b/src/Michelson/Typed/EntryPoints.hs @@ -9,6 +9,7 @@ , ParamNotes (..) , pattern ParamNotes + , starParamNotes , ArmCoord (..) , ArmCoords , ParamEpError (..) @@ -27,6 +28,7 @@ , mkEntryPointCall , tyImplicitAccountParam + , flattenEntryPoints -- * Re-exports , EpName (..) @@ -41,7 +43,7 @@ import Data.Constraint (Dict(..)) import Data.Default (Default(..)) import qualified Data.List.NonEmpty as NE -import Data.Singletons (Sing, SingI(..)) +import Data.Singletons (SingI(..)) import qualified Data.Text as T import Data.Typeable ((:~:)(..)) import Fmt (Buildable(..), pretty, (+|), (|+)) @@ -49,19 +51,22 @@ import Michelson.Text import Michelson.Typed.Annotation +import Michelson.Typed.Extract import Michelson.Typed.Scope import Michelson.Typed.Sing import Michelson.Typed.T +import qualified Michelson.Untyped as U import Michelson.Untyped.Annotation import Michelson.Untyped.EntryPoints import Tezos.Address (Address, ParseAddressError, formatAddress, parseAddress) +import Util.TH import Util.Typeable import Util.TypeLits ---------------------------------------------------------------------------- -- Primitives ---------------------------------------------------------------------------- - +-- -- EpAddress ---------------------------------------------------------------------------- @@ -72,11 +77,13 @@ -- ^ Address itself , eaEntryPoint :: EpName -- ^ Entrypoint name (might be empty) - } deriving stock (Show, Eq, Ord) + } deriving stock (Show, Eq, Ord, Generic) instance Buildable EpAddress where build = build . formatEpAddress +instance NFData EpAddress + formatEpAddress :: EpAddress -> Text formatEpAddress (EpAddress addr ep) | ep == def = formatAddress addr @@ -93,8 +100,10 @@ = ParseEpAddressBadAddress ParseAddressError | ParseEpAddressBadRefAnn Text | ParseEpAddressRefAnnError EpNameFromRefAnnError - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData ParseEpAddressError + instance Buildable ParseEpAddressError where build = \case ParseEpAddressBadAddress err -> build err @@ -134,17 +143,25 @@ -- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable. newtype ParamNotes (t :: T) = ParamNotesUnsafe { unParamNotes :: Notes t - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData (ParamNotes t) + pattern ParamNotes :: Notes t -> ParamNotes t pattern ParamNotes t <- ParamNotesUnsafe t {-# COMPLETE ParamNotes #-} +-- | Parameter without annotations. +starParamNotes :: SingI t => ParamNotes t +starParamNotes = ParamNotesUnsafe starNotes + -- | Coordinates of "arm" in Or tree, used solely in error messages. type ArmCoords = [ArmCoord] data ArmCoord = AcLeft | AcRight - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData ArmCoord + instance Buildable ArmCoord where build = \case AcLeft -> "left" @@ -154,8 +171,10 @@ data ParamEpError = ParamEpDuplicatedNames (NonEmpty EpName) | ParamEpUncallableArm ArmCoords - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData ParamEpError + instance Buildable ParamEpError where build = \case ParamEpDuplicatedNames names -> mconcat @@ -252,6 +271,8 @@ deriving stock instance Eq (EpLiftSequence arg param) deriving stock instance Show (EpLiftSequence arg param) +$(deriveGADTNFData ''EpLiftSequence) + instance Buildable (EpLiftSequence arg param) where build = \case EplArgHere -> "×" @@ -271,6 +292,8 @@ deriving stock instance Eq (EntryPointCallT param arg) deriving stock instance Show (EntryPointCallT param arg) +instance NFData (EntryPointCallT param arg) where + rnf (EntryPointCall name Proxy s) = rnf (name, s) instance Buildable (EntryPointCallT param arg) where build EntryPointCall{..} = @@ -318,6 +341,8 @@ guard (epc1 == epc2) deriving stock instance Show (SomeEntryPointCallT arg) +instance NFData (SomeEntryPointCallT arg) where + rnf (SomeEpc epc) = rnf epc instance Buildable (SomeEntryPointCallT arg) where build (SomeEpc epc) = build epc @@ -347,20 +372,21 @@ -- Returns 'Nothing' if entrypoint is not found. -- Does not treat default entrypoints specially. withEpLiftSequence - :: (ParameterScope param) + :: forall param r. + (ParameterScope param) => EpName - -> (Sing param, Notes param) + -> Notes param -> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r) -> Maybe r withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont = - case param of - (STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) -> + case (sing @param, param) of + (STOr lSing _, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) -> case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of (OpAbsent, NestedBigMapsAbsent) -> asum [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere) , guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere) - , withEpLiftSequence epName (lSing, lNotes) (cont . fmap @((,) _) EplWrapLeft) - , withEpLiftSequence epName (rSing, rNotes) (cont . fmap @((,) _) EplWrapRight) + , withEpLiftSequence epName lNotes (cont . fmap @((,) _) EplWrapLeft) + , withEpLiftSequence epName rNotes (cont . fmap @((,) _) EplWrapRight) ] _ -> Nothing @@ -381,11 +407,11 @@ mkEntryPointCall :: (ParameterScope param) => EpName - -> (Sing param, ParamNotes param) + -> ParamNotes param -> Maybe (MkEntryPointCallRes param) -mkEntryPointCall epName (paramSing, ParamNotes paramNotes) = +mkEntryPointCall epName (ParamNotes paramNotes) = asum - [ withEpLiftSequence epName (paramSing, paramNotes) $ \(argInfo, liftSeq) -> + [ withEpLiftSequence epName paramNotes $ \(argInfo, liftSeq) -> MkEntryPointCallRes argInfo $ EntryPointCall { epcName = epName , epcParamProxy = Proxy @@ -400,8 +426,17 @@ ] -- | "Parameter" type of implicit account. -tyImplicitAccountParam :: (Sing 'TUnit, ParamNotes 'TUnit) -tyImplicitAccountParam = (sing, ParamNotesUnsafe starNotes) +tyImplicitAccountParam :: ParamNotes 'TUnit +tyImplicitAccountParam = ParamNotesUnsafe starNotes + +-- Misc +---------------------------------------------------------------------------- + +-- | Flatten a provided list of notes to a map of its entrypoints and its +-- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how +-- duplicate entrypoints are handled. +flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type +flattenEntryPoints (unParamNotes -> notes) = mkEntrypointsMap (mkUType notes) -- TODO [#35]: We also need to be able to handle field annotation in root -- of parameter's @or@ tree. diff --git a/src/Michelson/Typed/Extract.hs b/src/Michelson/Typed/Extract.hs --- a/src/Michelson/Typed/Extract.hs +++ b/src/Michelson/Typed/Extract.hs @@ -12,11 +12,12 @@ , withUType , pattern AsUType + , pattern AsUTypeExt ) where -import Data.Singletons (SingI, sing) +import Data.Singletons (SingI) -import Michelson.Typed.Annotation (Notes(..)) +import Michelson.Typed.Annotation (Notes(..), notesSing) import Michelson.Typed.Sing (Sing(..), fromSingCT, fromSingT, withSomeSingCT) import Michelson.Typed.T (T(..), toUType) import qualified Michelson.Untyped as Un @@ -24,104 +25,104 @@ {-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} fromUType :: Un.Type -> T -fromUType ut = withUType ut (fromSingT . fst) +fromUType ut = withUType ut (fromSingT . notesSing) -mkUType :: Sing x -> Notes x -> Un.Type -mkUType s notes = case (s, notes) of +mkUType :: SingI x => Notes x -> Un.Type +mkUType notes = case (notesSing notes, notes) of (STc ct, NTc tn) -> Un.Type (Un.Tc (fromSingCT ct)) tn (STKey, NTKey tn) -> Un.Type Un.TKey tn (STUnit, NTUnit tn) -> Un.Type Un.TUnit tn (STSignature, NTSignature tn) -> Un.Type Un.TSignature tn (STChainId, NTChainId tn) -> Un.Type Un.TChainId tn - (STOption t, NTOption tn n) -> Un.Type (Un.TOption (mkUType t n)) tn - (STList t, NTList tn n) -> Un.Type (Un.TList (mkUType t n)) tn + (STOption _, NTOption tn n) -> Un.Type (Un.TOption (mkUType n)) tn + (STList _, NTList tn n) -> Un.Type (Un.TList (mkUType n)) tn (STSet ct, NTSet tn n) -> Un.Type (Un.TSet $ mkComp ct n) tn (STOperation, NTOperation tn) -> Un.Type Un.TOperation tn - (STContract t, NTContract tn n) -> - Un.Type (Un.TContract (mkUType t n)) tn - (STPair tl tr, NTPair tn fl fr nl nr) -> - Un.Type (Un.TPair fl fr (mkUType tl nl) (mkUType tr nr)) tn - (STOr tl tr, NTOr tn fl fr nl nr) -> - Un.Type (Un.TOr fl fr (mkUType tl nl) (mkUType tr nr)) tn - (STLambda p q, NTLambda tn np nq) -> - Un.Type (Un.TLambda (mkUType p np) (mkUType q nq)) tn - (STMap k v, NTMap tn nk nv) -> - Un.Type (Un.TMap (mkComp k nk) (mkUType v nv)) tn - (STBigMap k v, NTBigMap tn nk nv) -> - Un.Type (Un.TBigMap (mkComp k nk) (mkUType v nv)) tn + (STContract _, NTContract tn n) -> + Un.Type (Un.TContract (mkUType n)) tn + (STPair _ _, NTPair tn fl fr nl nr) -> + Un.Type (Un.TPair fl fr (mkUType nl) (mkUType nr)) tn + (STOr _ _, NTOr tn fl fr nl nr) -> + Un.Type (Un.TOr fl fr (mkUType nl) (mkUType nr)) tn + (STLambda _ _, NTLambda tn np nq) -> + Un.Type (Un.TLambda (mkUType np) (mkUType nq)) tn + (STMap k _, NTMap tn nk nv) -> + Un.Type (Un.TMap (mkComp k nk) (mkUType nv)) tn + (STBigMap k _, NTBigMap tn nk nv) -> + Un.Type (Un.TBigMap (mkComp k nk) (mkUType nv)) tn where mkComp t a = Un.Comparable (fromSingCT t) a -- | Convert 'Un.Type' to the isomorphic set of information from typed world. withUType :: Un.Type - -> (forall t. (Typeable t, SingI t) => (Sing t, Notes t) -> r) + -> (forall t. (Typeable t, SingI t) => Notes t -> r) -> r withUType (Un.Type ut tn) cont = case ut of Un.Tc tc -> withSomeSingCT tc $ - \(_ :: Sing tc) -> cont (sing @('Tc tc), NTc tn) + \(_ :: Sing tc) -> cont @('Tc tc) (NTc tn) Un.TKey -> - cont (sing @'TKey, NTKey tn) + cont (NTKey tn) Un.TUnit -> - cont (sing @'TUnit, NTUnit tn) + cont (NTUnit tn) Un.TSignature -> - cont (sing @'TSignature, NTSignature tn) + cont (NTSignature tn) Un.TChainId -> - cont (sing @'TChainId, NTChainId tn) + cont (NTChainId tn) Un.TOption internalT -> withUType internalT $ - \(_ :: Sing internalT, notesInternalT :: Notes internalT) -> - cont (sing @('TOption internalT), NTOption tn notesInternalT) + \(notesInternalT :: Notes internalT) -> + cont (NTOption tn notesInternalT) Un.TList listT -> withUType listT $ - \(_ :: Sing listT, notesListT :: Notes listT) -> - cont (sing @('TList listT), NTList tn notesListT) + \(notesListT :: Notes listT) -> + cont (NTList tn notesListT) Un.TSet (Un.Comparable sCT nsCT) -> withSomeSingCT sCT $ - \(_ :: Sing sCT) -> cont (sing @('TSet sCT), NTSet tn nsCT) + \(_ :: Sing sCT) -> cont @('TSet sCT) (NTSet tn nsCT) Un.TOperation -> - cont (sing @'TOperation, NTOperation tn) + cont (NTOperation tn) Un.TContract contractT -> withUType contractT $ - \(_ :: Sing contractT, notesContractT :: Notes contractT) -> - cont (sing @('TContract contractT), NTContract tn notesContractT) + \(notesContractT :: Notes contractT) -> + cont (NTContract tn notesContractT) Un.TPair la ra lt rt -> - withUType lt $ \(_ :: Sing lt, ln :: Notes lt) -> - withUType rt $ \(_ :: Sing rt, rn :: Notes rt) -> - cont (sing @('TPair lt rt), NTPair tn la ra ln rn) + withUType lt $ \ln -> + withUType rt $ \rn -> + cont (NTPair tn la ra ln rn) Un.TOr la ra lt rt -> - withUType lt $ \(_ :: Sing lt, ln :: Notes lt) -> - withUType rt $ \(_ :: Sing rt, rn :: Notes rt) -> - cont (sing @('TOr lt rt), NTOr tn la ra ln rn) + withUType lt $ \ln -> + withUType rt $ \rn -> + cont (NTOr tn la ra ln rn) Un.TLambda lt rt -> - withUType lt $ \(_ :: Sing lt, ln :: Notes lt) -> - withUType rt $ \(_ :: Sing rt, rn :: Notes rt) -> - cont (sing @('TLambda lt rt), NTLambda tn ln rn) + withUType lt $ \ln -> + withUType rt $ \rn -> + cont (NTLambda tn ln rn) Un.TMap (Un.Comparable keyT notesT) valT -> withSomeSingCT keyT $ \(_ :: Sing keyT) -> - withUType valT $ \(_ :: Sing valT, valN :: Notes valt) -> - cont (sing @('TMap keyT valT), NTMap tn notesT valN) + withUType valT $ \valN -> + cont @('TMap keyT _) (NTMap tn notesT valN) Un.TBigMap (Un.Comparable keyT notesT) valT -> withSomeSingCT keyT $ \(_ :: Sing keyT) -> - withUType valT $ \(_ :: Sing valT, valN :: Notes valt) -> - cont (sing @('TBigMap keyT valT), NTBigMap tn notesT valN) + withUType valT $ \valN -> + cont @('TBigMap keyT _) (NTBigMap tn notesT valN) -- Helper datatype for 'AsUType'. -data SomeTypedInfo = forall t. (Typeable t, SingI t) => SomeTypedInfo (Sing t, Notes t) +data SomeTypedInfo = forall t. (Typeable t, SingI t) => SomeTypedInfo (Notes t) --- | Transparently represent untyped 'Type' as wrapper over @(Sing t, Notes t)@ --- from typed world. +-- | Transparently represent untyped 'Type' as wrapper over @Notes t@ +-- from typed world with @SingI t@ constraint. -- -- As expression this carries logic of 'mkUType', and as pattern it performs -- 'withUType' but may make code a bit cleaner. @@ -129,7 +130,13 @@ -- Note about constraints: pattern signatures usually require two constraints - -- one they require and another one which they provide. In our case we require -- nothing (thus first constraint is @()@) and provide some knowledge about @t@. -pattern AsUType :: () => (Typeable t, SingI t) => Sing t -> Notes t -> Un.Type -pattern AsUType sng notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo (sng, notes)) - where AsUType sng notes = mkUType sng notes +pattern AsUType :: () => (Typeable t, SingI t) => Notes t -> Un.Type +pattern AsUType notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo notes) + where AsUType notes = mkUType notes {-# COMPLETE AsUType #-} + +-- | Similar to 'AsUType', but also gives 'Sing' for given type. +pattern AsUTypeExt :: () => (Typeable t, SingI t) => Sing t -> Notes t -> Un.Type +pattern AsUTypeExt sng notes <- AsUType notes@(notesSing -> sng) + where AsUTypeExt _ notes = AsUType notes +{-# COMPLETE AsUTypeExt #-} diff --git a/src/Michelson/Typed/Haskell/Doc.hs b/src/Michelson/Typed/Haskell/Doc.hs --- a/src/Michelson/Typed/Haskell/Doc.hs +++ b/src/Michelson/Typed/Haskell/Doc.hs @@ -305,9 +305,10 @@ -- | Doc element with description of contract storage type. newtype DStorageType = DStorageType DType + deriving stock Generic instance DocItem DStorageType where - type DocItemPosition DStorageType = 2035 + type DocItemPosition DStorageType = 835 docItemSectionName = Just "Storage" docItemToMarkdown lvl (DStorageType t) = docItemToMarkdown lvl t docItemDependencies (DStorageType t) = docItemDependencies t @@ -334,7 +335,7 @@ -- for the whole type) and zero or more type arguments. customTypeDocMdReference :: (Text, DType) -> [DType] -> WithinParens -> Markdown customTypeDocMdReference (typeCtorName, tyDoc) typeArgsDoc wp = - let DocItemRef (DocItemId ctorDocItemId) = docItemRef tyDoc + let DocItemRef ctorDocItemId = docItemRef tyDoc in applyWithinParens wpSmart $ mconcat . intersperse " " $ ( mdLocalRef (mdTicked $ build typeCtorName) ctorDocItemId @@ -569,9 +570,9 @@ typeDocName _ = "Text" typeDocMdReference p = customTypeDocMdReference ("Text", DType p) [] typeDocMdDescription = - "Michelson string.\n\ - \Not every text literal is valid string, see list of constraints in the \ - \[Official Michelson documentation](https://tezos.gitlab.io/whitedoc/michelson.html#constants)." + "Michelson string.\n\n\ + \This has to contain only ASCII characters with codes from [32; 126] range; \ + \additionally, newline feed character is allowed." typeDocDependencies _ = [] typeDocHaskellRep _ = Nothing diff --git a/src/Michelson/Typed/Haskell/Instr/Product.hs b/src/Michelson/Typed/Haskell/Instr/Product.hs --- a/src/Michelson/Typed/Haskell/Instr/Product.hs +++ b/src/Michelson/Typed/Haskell/Instr/Product.hs @@ -18,7 +18,6 @@ import Data.Type.Bool (If) import Data.Type.Equality (type (==)) import Data.Vinyl.Core (Rec(..)) -import Data.Vinyl.Derived (Label) import Data.Vinyl.TypeLevel (type (++)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G @@ -29,6 +28,7 @@ import Michelson.Typed.Haskell.Value import Michelson.Typed.Instr import Michelson.Text +import Util.Label (Label) import Util.Named (NamedInner) import Util.Type diff --git a/src/Michelson/Typed/Haskell/Instr/Sum.hs b/src/Michelson/Typed/Haskell/Instr/Sum.hs --- a/src/Michelson/Typed/Haskell/Instr/Sum.hs +++ b/src/Michelson/Typed/Haskell/Instr/Sum.hs @@ -40,7 +40,6 @@ import Data.Type.Bool (If, type (||)) import Data.Type.Equality (type (==)) import Data.Vinyl.Core (Rec(..)) -import Data.Vinyl.Derived (Label) import Data.Vinyl.TypeLevel (type (++)) import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G @@ -59,6 +58,7 @@ import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp) import Tezos.Crypto (KeyHash, PublicKey, Signature) +import Util.Label (Label) import Util.Type import Util.TypeTuple @@ -467,11 +467,11 @@ -- | Pattern-match on the given datatype. instrCase :: forall dt out inp. - InstrCaseC dt inp out + InstrCaseC dt => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt ': inp) out instrCase = gInstrCase @(G.Rep dt) -type InstrCaseC dt inp out = (GenericIsoValue dt, GInstrCase (G.Rep dt)) +type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (G.Rep dt)) -- | In what different case branches differ - related constructor name and -- input stack type which the branch starts with. diff --git a/src/Michelson/Typed/Haskell/Value.hs b/src/Michelson/Typed/Haskell/Value.hs --- a/src/Michelson/Typed/Haskell/Value.hs +++ b/src/Michelson/Typed/Haskell/Value.hs @@ -26,9 +26,9 @@ , totsAppendLemma ) where -import Data.Default (Default (..)) +import Data.Constraint ((:-)(..), Dict(..)) +import Data.Default (Default(..)) import qualified Data.Kind as Kind -import Data.Constraint (Dict (..), (:-)(..)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Vinyl.Core (Rec(..)) @@ -36,6 +36,7 @@ import GHC.Generics ((:*:)(..), (:+:)(..)) import qualified GHC.Generics as G import Named (NamedF(..)) +import Test.QuickCheck (Arbitrary(..)) import Michelson.Text import Michelson.Typed.Aliases @@ -44,7 +45,7 @@ import Michelson.Typed.T import Michelson.Typed.Value import Tezos.Address (Address) -import Tezos.Core (Mutez, Timestamp, ChainId) +import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, PublicKey, Signature) import Util.Type @@ -329,6 +330,9 @@ type ToT (BigMap k v) = 'TBigMap (ToCT k) (ToT v) toVal = VBigMap . Map.mapKeys toCVal . Map.map toVal . unBigMap fromVal (VBigMap x) = BigMap $ Map.map fromVal $ Map.mapKeys fromCVal x + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (BigMap k v) where + arbitrary = BigMap <$> arbitrary -- Generic magic ---------------------------------------------------------------------------- diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs --- a/src/Michelson/Typed/Instr.hs +++ b/src/Michelson/Typed/Instr.hs @@ -9,12 +9,13 @@ , mkStackRef , PrintComment (..) , TestAssert (..) - , Contract + , ContractCode , FullContract (..) , fcParamNotes , mapFullContractCode , pattern CAR , pattern CDR + , pattern UNPAIR , PackedNotes(..) , ConstraintDIPN , ConstraintDIPN' @@ -25,13 +26,14 @@ ) where import Data.Singletons (SingI(..)) -import Fmt ((+||), (||+)) +import Fmt (Buildable(..), (+||), (||+)) import qualified GHC.TypeNats as GHC (Nat) import qualified Text.Show +import Michelson.Doc +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, needsParens, printDocS) import Michelson.Typed.Annotation (Notes(..)) import Michelson.Typed.Arith -import Michelson.Doc import Michelson.Typed.EntryPoints import Michelson.Typed.Polymorphic import Michelson.Typed.Scope @@ -39,6 +41,7 @@ import Michelson.Typed.Value (ContractInp, ContractOut, Value'(..)) import Michelson.Untyped (Annotation(..), FieldAnn, VarAnn) import Util.Peano +import Util.TH import Util.Type (type (++), KnownList) -- | A wrapper to wrap annotations and corresponding singleton. @@ -47,11 +50,20 @@ -- the `Show` instance for `Instr` as `Sing a` does not have a `Show` -- instance on its own. data PackedNotes a where - PackedNotes :: Notes a -> Sing a -> PackedNotes (a ': s) + PackedNotes :: SingI a => Notes a -> PackedNotes (a ': s) +instance NFData (PackedNotes a) where + rnf (PackedNotes n) = rnf n + instance Show (PackedNotes a) where - show (PackedNotes n _) = show n + show = printDocS True . renderDoc needsParens +instance Buildable (PackedNotes a) where + build = buildRenderDoc + +instance RenderDoc (PackedNotes a) where + renderDoc pn (PackedNotes n) = renderDoc pn n + -- | Constraint that is used in DIPN, we want to share it with -- typechecking code and eDSL code. type ConstraintDIPN' kind (n :: Peano) (inp :: [kind]) @@ -159,15 +171,15 @@ DROP :: Instr (a ': s) s DROPN :: forall (n :: Peano) s. - (SingI n, KnownPeano n, RequireLongerOrSameLength s n) + (SingI n, KnownPeano n, RequireLongerOrSameLength s n, NFData (Sing n)) => Sing n -> Instr s (Drop n s) DUP :: Instr (a ': s) (a ': a ': s) SWAP :: Instr (a ': b ': s) (b ': a ': s) DIG - :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a + :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a, NFData (Sing n)) => Sing n -> Instr inp out DUG - :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a + :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a, NFData (Sing n)) => Sing n -> Instr inp out PUSH :: forall t s . ConstantScope t @@ -223,7 +235,7 @@ => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s) DIP :: Instr a c -> Instr (b ': a) (b ': c) DIPN - :: forall (n :: Peano) inp out s s'. ConstraintDIPN n inp out s s' + :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', (NFData (Sing n))) => Sing n -> Instr s s' -> Instr inp out FAILWITH :: (Typeable a, SingI a) => Instr (a ': s) t CAST :: forall a s . SingI a => Instr (a ': s) (a ': s) @@ -345,19 +357,23 @@ instance Monoid (Instr s s) where mempty = Nop -instance NFData (Instr inp out) where - -- This is the simplest way, and we don't care much about performance in tests. - -- May be unsatisfactory for benchmarks though. - -- If @instance Show@ is not automatically derived anymore, or you have other - -- problems with this instance, then please reimplement it manually. - rnf = rnf @String . show - -pattern CAR :: Instr ('TPair a b : s) (a : s) +-- We have to write down pattern like this because simple +-- @Instr (TPair a b : s) (a : s)@ signature would assume that we /expect/ +-- the input stack to have pair on top, but we want to /provide/ this info +-- in scope of a pattern-match. +-- In pattern declaration we have to write down the two mentioned constraints +-- explicitly. +-- +-- Note that internally GADT constructors are rewritten in the very same way. +pattern CAR :: () => (i ~ ('TPair a b : s), o ~ (a : s)) => Instr i o pattern CAR = AnnCAR (AnnotationUnsafe "") -pattern CDR :: Instr ('TPair a b : s) (b: s) +pattern CDR :: () => (i ~ ('TPair a b : s), o ~ (b : s)) => Instr i o pattern CDR = AnnCDR (AnnotationUnsafe "") +pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : b : s)) => Instr i o +pattern UNPAIR = Seq DUP (Seq CAR (DIP CDR)) + data TestAssert (s :: [T]) where TestAssert :: (Typeable out) @@ -367,6 +383,8 @@ -> TestAssert inp deriving stock instance Show (TestAssert s) +instance NFData (TestAssert s) where + rnf (TestAssert a b c) = rnf (a, b, c) -- | A reference into the stack of a given type. data StackRef (st :: [T]) where @@ -375,6 +393,9 @@ :: (KnownPeano idx, SingI idx, RequireLongerThan st idx) => Sing (idx :: Peano) -> StackRef st +instance NFData (StackRef st) where + rnf (StackRef s) = rnf s + instance Eq (StackRef st) where StackRef snat1 == StackRef snat2 = peanoVal snat1 == peanoVal snat2 @@ -394,6 +415,8 @@ } deriving stock (Eq, Show, Generic) deriving newtype (Semigroup, Monoid) +instance NFData (PrintComment st) + instance IsString (PrintComment st) where fromString = PrintComment . one . Left . fromString @@ -401,28 +424,35 @@ = TEST_ASSERT (TestAssert s) | PRINT (PrintComment s) | DOC_ITEM SomeDocItem - deriving stock (Show) + deriving stock (Show, Generic) +instance NFData (ExtInstr s) + --------------------------------------------------- -type Contract cp st = Instr (ContractInp cp st) (ContractOut st) +type ContractCode cp st = Instr (ContractInp cp st) (ContractOut st) -- | Typed contract and information about annotations -- which is not present in the contract code. --- TODO [#12]: rename this to 'Contract' and the current 'Contract' to 'ContractCode'? +-- TODO [#12]: rename this to 'Contract' data FullContract cp st = (ParameterScope cp, StorageScope st) => FullContract - { fcCode :: Contract cp st + { fcCode :: ContractCode cp st , fcParamNotesSafe :: ParamNotes cp , fcStoreNotes :: Notes st } deriving stock instance Show (FullContract cp st) +deriving stock instance Eq (ContractCode cp st) => Eq (FullContract cp st) +instance NFData (FullContract cp st) where + rnf (FullContract a b c) = rnf (a, b, c) fcParamNotes :: FullContract cp st -> Notes cp fcParamNotes = unParamNotes . fcParamNotesSafe mapFullContractCode - :: (Contract cp st -> Contract cp st) + :: (ContractCode cp st -> ContractCode cp st) -> FullContract cp st -> FullContract cp st mapFullContractCode f contract = contract { fcCode = f $ fcCode contract } + +$(deriveGADTNFData ''Instr) diff --git a/src/Michelson/Typed/T.hs b/src/Michelson/Typed/T.hs --- a/src/Michelson/Typed/T.hs +++ b/src/Michelson/Typed/T.hs @@ -31,7 +31,9 @@ | TLambda T T | TMap CT T | TBigMap CT T - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + +instance NFData T -- | Converts from 'T' to 'Michelson.Type.Type'. toUType :: T -> Un.Type diff --git a/src/Michelson/Typed/Value.hs b/src/Michelson/Typed/Value.hs --- a/src/Michelson/Typed/Value.hs +++ b/src/Michelson/Typed/Value.hs @@ -22,6 +22,7 @@ , addressToVContract , buildVContract , compileEpLiftSequence + , liftCallArg ) where import Data.Singletons (SingI) @@ -35,6 +36,7 @@ import Tezos.Address (Address) import Tezos.Core (ChainId, Mutez) import Tezos.Crypto (KeyHash, PublicKey, Signature) +import Util.TH import Util.Typeable -- | Data type, representing operation, list of which is returned @@ -49,6 +51,7 @@ OpSetDelegate :: SetDelegate -> Operation' instr OpCreateContract :: ( Show (instr (ContractInp cp st) (ContractOut st)) + , NFData (instr (ContractInp cp st) (ContractOut st)) , Typeable instr, ParameterScope cp, StorageScope st) => CreateContract instr cp st -> Operation' instr @@ -75,16 +78,20 @@ { ttTransferArgument :: Value' instr p , ttAmount :: Mutez , ttContract :: Value' instr ('TContract p) - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData (TransferTokens instr p) + instance Buildable (TransferTokens instr p) where build TransferTokens {..} = "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+ "" data SetDelegate = SetDelegate { sdMbKeyHash :: Maybe KeyHash - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData SetDelegate + instance Buildable SetDelegate where build (SetDelegate mbDelegate) = "Set delegate to " <> maybe "" build mbDelegate @@ -101,6 +108,9 @@ , ccContractCode :: instr (ContractInp cp st) (ContractOut st) } +instance NFData (instr (ContractInp cp st) (ContractOut st)) => NFData (CreateContract instr cp st) where + rnf (CreateContract a b c d e) = rnf (a, b, c, d, e) + instance Buildable (CreateContract instr cp st) where build CreateContract {..} = "Create a new contract with" <> @@ -123,6 +133,9 @@ RfAlwaysFails :: (forall o'. instr i o') -> RemFail instr i o deriving stock instance (forall o'. Show (instr i o')) => Show (RemFail instr i o) +instance (forall o'. NFData (instr i o')) => NFData (RemFail instr i o) where + rnf (RfNormal a) = rnf a + rnf (RfAlwaysFails a) = rnf a -- | Ignoring distinction between constructors here, comparing only semantics. instance Eq (instr i o) => Eq (RemFail instr i o) where @@ -179,6 +192,7 @@ ( forall i o. ( Show (instr i o) , Eq (instr i o) + , NFData (instr i o) ) ) => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out) @@ -232,6 +246,13 @@ EplWrapLeft els -> VOr . Left . compileEpLiftSequence els EplWrapRight els -> VOr . Right . compileEpLiftSequence els +-- | Lift entrypoint argument to full parameter. +liftCallArg + :: EntryPointCallT param arg + -> Value' instr arg + -> Value' instr param +liftCallArg epc = compileEpLiftSequence (epcLiftSequence epc) + -- TODO: actually we should handle big maps with something close -- to following: -- @@ -245,3 +266,7 @@ -- -- data BigMap op ref k v = BigMap -- { bmRef :: ref k v, bmChanges :: Map (CValue k) (Value'Op (Value' cp v)) } + +$(deriveGADTNFData ''Operation') +$(deriveGADTNFData ''Value') + diff --git a/src/Michelson/Untyped/Annotation.hs b/src/Michelson/Untyped/Annotation.hs --- a/src/Michelson/Untyped/Annotation.hs +++ b/src/Michelson/Untyped/Annotation.hs @@ -4,11 +4,24 @@ ( Annotation (..) , pattern Annotation , pattern WithAnn + + -- * Annotation Set + , AnnotationSet + , emptyAnnSet + , fullAnnSet + , isNoAnnSet + , minAnnSetSize + , singleAnnSet + , singleGroupAnnSet + + -- * Rendering , KnownAnnTag(..) , TypeAnn , FieldAnn , VarAnn , SomeAnn + + -- * Creation and conversions , noAnn , ann , mkAnnotation @@ -16,8 +29,6 @@ , specialFieldAnn , isValidAnnStart , isValidAnnBodyChar - , renderAnn - , renderWEAnn , unifyAnn , ifAnnUnified , disjoinVn @@ -28,14 +39,16 @@ import Data.Char (isAlpha, isAscii, isNumber) import Data.Data (Data(..)) import Data.Default (Default(..)) +import qualified Data.Kind as Kind import qualified Data.Text as T +import Data.Typeable ((:~:)(..), eqT) import Fmt (Buildable(build)) import Instances.TH.Lift () import Language.Haskell.TH.Lift (deriveLift) -import Text.PrettyPrint.Leijen.Text (Doc, textStrict) +import Text.PrettyPrint.Leijen.Text (Doc, (<+>), hsep, textStrict) import qualified Text.Show -import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc) +import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS) -- | Generic Type/Field/Variable Annotation -- @@ -47,6 +60,8 @@ deriving stock (Eq, Data, Functor, Generic) deriving newtype (IsString) +instance NFData (Annotation tag) + pattern Annotation :: Text -> Annotation tag pattern Annotation ann <- AnnotationUnsafe ann @@ -55,11 +70,92 @@ instance Default (Annotation tag) where def = noAnn -class KnownAnnTag tag where +-------------------------------------------------------------------------------- +-- Annotation Set +-------------------------------------------------------------------------------- + +-- | An 'AnnotationSet' contains all the type/field/variable 'Annotation's +-- , with each group in order, associated with an entity. +-- Note that in its rendering/show instances the unnecessary annotations will be +-- omitted, as well as in some of the functions operating with it. +-- Necessary 'Annotation's are the ones strictly required for a consistent +-- representation. +-- In particular, for each group (t/f/v): +-- - if all annotations are 'noAnn' they are all omitted +-- - if one or more 'noAnn' follow a non-empty 'ann', they are omitted +-- - if one or more 'noAnn' precede a non-empty 'ann', they are kept +-- - every non-empty 'ann' is obviously kept +-- This is why order for each group is important as well as separation of +-- different groups of 'Annotation's. +data AnnotationSet = AnnotationSet + { asTypes :: [TypeAnn] + , asFields :: [FieldAnn] + , asVars :: [VarAnn] + } deriving Eq + +instance Semigroup AnnotationSet where + (AnnotationSet ts1 fs1 vs1) <> (AnnotationSet ts2 fs2 vs2) = AnnotationSet {..} + where + asTypes = ts1 <> ts2 + asFields = fs1 <> fs2 + asVars = vs1 <> vs2 + +instance Monoid AnnotationSet where + mempty = emptyAnnSet + +-- | An 'AnnotationSet' without any 'Annotation'. +emptyAnnSet :: AnnotationSet +emptyAnnSet = AnnotationSet [] [] [] + +-- | An 'AnnotationSet' with only a single 'Annotation' (of any kind). +singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet +singleAnnSet an = singleGroupAnnSet [an] + +-- | An 'AnnotationSet' with several 'Annotation's of the same kind. +singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet +singleGroupAnnSet ans = AnnotationSet {..} + where + asTypes = case eqT @tag @TypeTag of Just Refl -> ans; Nothing -> [] + asFields = case eqT @tag @FieldTag of Just Refl -> ans; Nothing -> [] + asVars = case eqT @tag @VarTag of Just Refl -> ans; Nothing -> [] + +-- | An 'AnnotationSet' built from all 3 kinds of 'Annotation'. +fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet +fullAnnSet asTypes asFields asVars = AnnotationSet {..} + +-- | Returns 'True' if all 'Annotation's in the Set are unnecessary/empty/'noAnn'. +-- False otherwise. +isNoAnnSet :: AnnotationSet -> Bool +isNoAnnSet annSet = null asTypes && null asFields && null asVars + where AnnotationSet {..} = minimizeAnnSet annSet + +-- | Returns the amount of 'Annotation's that are necessary for a consistent +-- representation. See 'AnnotationSet'. +minAnnSetSize :: AnnotationSet -> Int +minAnnSetSize annSet = length asTypes + length asFields + length asVars + where AnnotationSet {..} = minimizeAnnSet annSet + +-- | Removes all unnecessary 'Annotation's. See 'AnnotationSet'. +minimizeAnnSet :: AnnotationSet -> AnnotationSet +minimizeAnnSet (AnnotationSet ts fs vs) = AnnotationSet {..} + where + asTypes = trimEndNoAnn ts + asFields = trimEndNoAnn fs + asVars = trimEndNoAnn vs + +-- | Removes all unnecessary 'Annotation's from a list of the same type +trimEndNoAnn :: [Annotation tag] -> [Annotation tag] +trimEndNoAnn = foldr (\a lst -> if null lst && a == noAnn then [] else a : lst) [] + +-------------------------------------------------------------------------------- +-- Rendering +-------------------------------------------------------------------------------- + +class Typeable (tag :: Kind.Type) => KnownAnnTag tag where annPrefix :: Text instance KnownAnnTag tag => Show (Annotation tag) where - show (Annotation x) = toString $ annPrefix @tag <> x + show = printDocS True . renderDoc doesntNeedParens data TypeTag data FieldTag @@ -81,22 +177,34 @@ instance KnownAnnTag tag => RenderDoc (Annotation tag) where renderDoc _ = renderAnn -renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc -renderAnn a@(Annotation text) - | a == noAnn = "" - | otherwise = textStrict $ annPrefix @tag <> text +instance KnownAnnTag tag => Buildable (Annotation tag) where + build = buildRenderDoc --- | Prints empty prefix in case of @noAnn@. --- --- Such functionality is required in case when instruction --- has two annotations of the same type, former is empty --- and the latter is not. So that `PAIR noAnn noAnn noAnn %kek` --- is printed as `PAIR % %kek` -renderWEAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc -renderWEAnn (Annotation text) = textStrict $ annPrefix @tag <> text +instance Show AnnotationSet where + show = printDocS True . renderDoc doesntNeedParens -instance KnownAnnTag tag => Buildable (Annotation tag) where +instance RenderDoc AnnotationSet where + renderDoc _ (AnnotationSet {..}) = + renderAnnGroup asTypes <+> renderAnnGroup asFields <+> renderAnnGroup asVars + +instance Buildable AnnotationSet where build = buildRenderDoc + +-- | Renders a single 'Annotation', this is used in every rendering instance of it. +-- Note that this also renders empty ones/'noAnn's because a single 'Annotation' +-- does not have enough context to know if it can be omitted, use 'singleAnnSet' +-- if you want to hide it instead. +renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc +renderAnn (Annotation text) = textStrict $ annPrefix @tag <> text + +-- | Renders a list of 'Annotation's, omitting unnecessary empty ones/'noAnn'. +-- This is used (3 times) to render an 'AnnotationSet'. +renderAnnGroup :: KnownAnnTag tag => [Annotation tag] -> Doc +renderAnnGroup = hsep . map renderAnn . trimEndNoAnn + +-------------------------------------------------------------------------------- +-- Creation and conversions +-------------------------------------------------------------------------------- noAnn :: Annotation a noAnn = AnnotationUnsafe "" diff --git a/src/Michelson/Untyped/Contract.hs b/src/Michelson/Untyped/Contract.hs --- a/src/Michelson/Untyped/Contract.hs +++ b/src/Michelson/Untyped/Contract.hs @@ -23,6 +23,8 @@ , code :: [op] } deriving stock (Eq, Show, Functor, Data, Generic) +instance NFData op => NFData (Contract' op) + instance (RenderDoc op) => RenderDoc (Contract' op) where renderDoc pn (Contract parameter storage code) = assertParensNotNeeded pn $ "parameter" <+> renderDoc needsParens (Prettier parameter) <> semi <$$> diff --git a/src/Michelson/Untyped/EntryPoints.hs b/src/Michelson/Untyped/EntryPoints.hs --- a/src/Michelson/Untyped/EntryPoints.hs +++ b/src/Michelson/Untyped/EntryPoints.hs @@ -6,13 +6,17 @@ , epNameFromRefAnn , epNameToRefAnn , EpNameFromRefAnnError (..) + , mkEntrypointsMap ) where import Data.Default (Default(..)) -import Fmt (Buildable(..), (+|), (|+)) +import qualified Data.Map as Map +import Fmt (Buildable(..), pretty, (+|), (|+)) import Test.QuickCheck (Arbitrary(..), suchThatMap) import Michelson.Untyped.Annotation +import Michelson.Untyped.Type +import Util.CLI -- | Entrypoint name. -- @@ -20,8 +24,10 @@ -- Cannot be equal to "default", the reference implementation forbids that. -- Also, set of allowed characters should be the same as in annotations. newtype EpName = EpNameUnsafe { unEpName :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) +instance NFData EpName + pattern DefEpName :: EpName pattern DefEpName = EpNameUnsafe "" @@ -50,8 +56,10 @@ data EpNameFromRefAnnError = InEpNameBadAnnotation FieldAnn - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData EpNameFromRefAnnError + instance Buildable EpNameFromRefAnnError where build = \case InEpNameBadAnnotation (Annotation an) -> @@ -72,3 +80,35 @@ instance Arbitrary FieldAnn => Arbitrary EpName where arbitrary = arbitrary `suchThatMap` (rightToMaybe . epNameFromRefAnn) + +instance HasCLReader EpName where + getReader = eitherReader parseEntrypointDo + where + parseEntrypointDo (toText -> txt) = do + an <- + mkAnnotation txt + & first (mappend "Failed to parse entrypoint: " . pretty) + epNameFromRefAnn an + & first pretty + getMetavar = "ENTRYPOINT" + +-- | Given an untyped type, extract a map that maps entrypoint names to the +-- their parameter types. If there are duplicate entrypoints in the given Type +-- then the duplicate entrypoints at a deeper nesting level will get +-- overwritten with the ones that are on top. +mkEntrypointsMap :: Type -> Map EpName Type +mkEntrypointsMap (Type t _) = case t of + -- We are only interested in `Or` branches to extract entrypoint + -- annotations. + TOr f1 f2 t1 t2 -> extractSubmap f1 t1 <> extractSubmap f2 t2 + _ -> mempty + where + extractSubmap :: FieldAnn -> Type -> Map EpName Type + extractSubmap f1 t1 = let + -- If the field annotation is not empty then merge this field + -- annotation/type pair with the entrypoint map of inner type. Else + -- just fetch entrypoint map of inner type. + innerMap = mkEntrypointsMap t1 + in case epNameFromParamAnn f1 of + Just epName -> Map.singleton epName t1 <> innerMap + Nothing -> innerMap diff --git a/src/Michelson/Untyped/Ext.hs b/src/Michelson/Untyped/Ext.hs --- a/src/Michelson/Untyped/Ext.hs +++ b/src/Michelson/Untyped/Ext.hs @@ -38,6 +38,8 @@ | UPRINT PrintComment -- ^ Print a comment with optional embedded @StackRef@s deriving stock (Eq, Show, Data, Generic, Functor) +instance NFData op => NFData (ExtInstrAbstract op) + instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where renderDoc _ = \case @@ -55,11 +57,15 @@ newtype StackRef = StackRef Natural deriving stock (Eq, Show, Data, Generic) +instance NFData StackRef + instance Buildable StackRef where build (StackRef i) = "%[" <> show i <> "]" newtype Var = Var T.Text deriving stock (Eq, Show, Ord, Data, Generic) +instance NFData Var + instance Buildable Var where build = genericF @@ -69,6 +75,8 @@ | TyCon Type deriving stock (Eq, Show, Data, Generic) +instance NFData TyVar + instance Buildable TyVar where build = genericF @@ -79,6 +87,8 @@ | StkCons TyVar StackTypePattern deriving stock (Eq, Show, Data, Generic) +instance NFData StackTypePattern + -- | Convert 'StackTypePattern' to a list of types. Also returns -- 'Bool' which is 'True' if the pattern is a fixed list of types and -- 'False' if it's a pattern match on the head of the stack. @@ -103,6 +113,8 @@ , outPattern :: StackTypePattern } deriving stock (Eq, Show, Data, Generic) +instance NFData StackFn + instance Buildable StackFn where build = genericF @@ -118,6 +130,8 @@ { unUPrintComment :: [Either T.Text StackRef] } deriving stock (Eq, Show, Data, Generic) +instance NFData PrintComment + instance Buildable PrintComment where build = foldMap (either build build) . unUPrintComment @@ -127,6 +141,8 @@ , tassComment :: PrintComment , tassInstrs :: [op] } deriving stock (Eq, Show, Functor, Data, Generic) + +instance NFData op => NFData (TestAssert op) instance Buildable code => Buildable (TestAssert code) where build = genericF diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs --- a/src/Michelson/Untyped/Instr.hs +++ b/src/Michelson/Untyped/Instr.hs @@ -20,11 +20,14 @@ import Generics.SYB (everywhere, mkT) import Text.PrettyPrint.Leijen.Text (Doc, align, braces, enclose, indent, line, nest, space, text, (<$$>), (<+>)) +import qualified Text.Show import Michelson.ErrorPos (InstrCallStack) import Michelson.Printer.Util - (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList, spaces) -import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, VarAnn, noAnn, renderWEAnn) + (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS, + renderOpsList, spaces) +import Michelson.Untyped.Annotation + (Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet) import Michelson.Untyped.Contract (Contract'(..)) import Michelson.Untyped.Ext (ExtInstrAbstract) import Michelson.Untyped.Type (Comparable, Type) @@ -45,6 +48,8 @@ | WithSrcEx InstrCallStack ExpandedOp deriving stock (Show, Eq, Data, Generic) +instance NFData ExpandedOp + instance RenderDoc ExpandedOp where renderDoc pn (WithSrcEx _ op) = renderDoc pn op renderDoc pn (PrimEx i) = renderDoc pn i @@ -188,8 +193,13 @@ | SENDER VarAnn | ADDRESS VarAnn | CHAIN_ID VarAnn - deriving stock (Eq, Show, Functor, Data, Generic) + deriving stock (Eq, Functor, Data, Generic) +instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where + show = printDocS True . renderDoc doesntNeedParens + +instance NFData op => NFData (InstrAbstract op) + instance (RenderDoc op) => RenderDoc (InstrAbstract op) where renderDoc pn = \case EXT extInstr -> renderDoc pn extInstr @@ -200,23 +210,23 @@ DIG n -> "DIG" <+> text (show n) DUG n -> "DUG" <+> text (show n) PUSH va t v -> "PUSH" <+> renderAnnot va <+> renderTy t <+> renderDoc needsParens v - SOME ta va -> "SOME" <+> renderAnnot ta <+> renderAnnot va - NONE ta va t -> "NONE" <+> renderAnnot ta <+> renderAnnot va <+> renderTy t - UNIT ta va -> "UNIT" <+> renderAnnot ta <+> renderAnnot va + SOME ta va -> "SOME" <+> renderAnnots [ta] [] [va] + NONE ta va t -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t + UNIT ta va -> "UNIT" <+> renderAnnots [ta] [] [va] IF_NONE x y -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y) - PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2 - CAR va fa -> "CAR" <+> renderAnnot va <+> renderAnnot fa - CDR va fa -> "CDR" <+> renderAnnot va <+> renderAnnot fa - LEFT ta va fa1 fa2 t -> "LEFT" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2 <+> renderTy t - RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2 <+> renderTy t + PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va] + 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" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y) - NIL ta va t -> "NIL" <+> renderAnnot ta <+> renderAnnot va <+> renderTy t + NIL ta va t -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t CONS va -> "CONS" <+> renderAnnot va IF_CONS x y -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y) SIZE va -> "SIZE" <+> renderAnnot va - EMPTY_SET ta va t -> "EMPTY_SET" <+> renderAnnot ta <+> renderAnnot va <+> renderComp t - EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderAnnot ta <+> renderAnnot va <+> renderComp c <+> renderTy t - EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnot ta <+> renderAnnot va <+> renderComp c <+> renderTy t + 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" <+> renderAnnot va <$$> spaces 4 <> nest 5 (renderOps s) ITER s -> "ITER" <+> nest 6 (renderOps s) MEM va -> "MEM" <+> renderAnnot va @@ -225,16 +235,16 @@ IF x y -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y) LOOP s -> "LOOP" <+> nest 6 (renderOps s) LOOP_LEFT s -> "LOOP_LEFT" <+> nest 11 (renderOps s) - LAMBDA va t r s -> "LAMBDA" <+> renderAnnot va <+> renderTy t <+> renderTy r <$$> spaces 7 <> nest 8 (renderOps s) + LAMBDA va t r s -> "LAMBDA" <+> renderAnnot va <$$> (spaces 2 <> renderTy t) <$$> (spaces 2 <> renderTy r) <$$> spaces 2 <> nest 3 (renderOps s) EXEC va -> "EXEC" <+> renderAnnot va APPLY va -> "APPLY" <+> renderAnnot va DIP s -> "DIP" <+> nest 5 (renderOps s) - DIPN n s -> "DIP" <+> text (show n) <> line <> indent (3 + (length $ show @Text n)) (renderOps s) + DIPN n s -> "DIP" <+> text (show n) <> line <> indent 4 (renderOps s) FAILWITH -> "FAILWITH" CAST va t -> "CAST" <+> renderAnnot va <+> renderTy t RENAME va -> "RENAME" <+> renderAnnot va PACK va -> "PACK" <+> renderAnnot va - UNPACK ta va t -> "UNPACK" <+> renderAnnot ta <+> renderAnnot va <+> renderTy t + UNPACK ta va t -> "UNPACK" <+> renderAnnots [ta] [] [va] <+> renderTy t CONCAT va -> "CONCAT" <+> renderAnnot va SLICE va -> "SLICE" <+> renderAnnot va ISNAT va -> "ISNAT" <+> renderAnnot va @@ -258,13 +268,13 @@ LE va -> "LE" <+> renderAnnot va GE va -> "GE" <+> renderAnnot va INT va -> "INT" <+> renderAnnot va - SELF va fa -> "SELF" <+> renderAnnot va <+> renderAnnot fa - CONTRACT va fa t -> "CONTRACT" <+> renderAnnot va <+> renderAnnot fa <+> renderTy t + SELF va fa -> "SELF" <+> renderAnnots [] [fa] [va] + CONTRACT va fa t -> "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" <+> renderTwoAnnotations va1 va2 <$$> (indent 2 $ braces $ body) + in "CREATE_CONTRACT" <+> renderAnnots [] [] [va1, va2] <$$> (indent 2 $ braces $ body) IMPLICIT_ACCOUNT va -> "IMPLICIT_ACCOUNT" <+> renderAnnot va NOW va -> "NOW" <+> renderAnnot va AMOUNT va -> "AMOUNT" <+> renderAnnot va @@ -283,14 +293,12 @@ renderTy = renderDoc @Type needsParens renderComp = renderDoc @Comparable needsParens renderOps = renderOpsList False - renderTwoAnnotations ann1 ann2 = - -- If both annotations are noAnn we don't want to explicitly print them - if (ann1 /= noAnn || ann2 /= noAnn) - then renderWEAnn ann1 <+> renderWEAnn ann2 - else renderDoc doesntNeedParens ann1 <+> renderDoc doesntNeedParens ann2 - renderAnnot :: RenderDoc (Annotation tag) => Annotation tag -> Doc - renderAnnot = renderDoc @(Annotation _) needsParens + renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc + renderAnnot = renderDoc doesntNeedParens . singleAnnSet + + renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc + renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs isRenderable = \case EXT extInstr -> isRenderable extInstr diff --git a/src/Michelson/Untyped/Type.hs b/src/Michelson/Untyped/Type.hs --- a/src/Michelson/Untyped/Type.hs +++ b/src/Michelson/Untyped/Type.hs @@ -60,27 +60,30 @@ import Michelson.Printer.Util (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens, needsParens, wrapInParens) -import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, noAnn, renderAnn) +import Michelson.Untyped.Annotation + (AnnotationSet, FieldAnn, TypeAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet) -- Annotated type data Type = Type ~T TypeAnn deriving stock (Eq, Show, Data, Generic) +instance NFData Type + instance RenderDoc Comparable where renderDoc np (Comparable ct ta) = addParens np $ - renderCT ct <+> renderAnn ta + renderCT ct <+> renderDoc doesntNeedParens (singleAnnSet ta) instance RenderDoc (Prettier Type) where renderDoc pn (Prettier w) = case w of - (Type t ta) -> renderType t False pn (Just ta) Nothing + (Type t ta) -> renderType t False pn (singleAnnSet ta) instance RenderDoc Type where - renderDoc pn (Type t ta) = renderType t True pn (Just ta) Nothing + renderDoc pn (Type t ta) = renderType t True pn (singleAnnSet ta) instance RenderDoc T where - renderDoc pn t = renderType t True pn Nothing Nothing + renderDoc pn t = renderType t True pn emptyAnnSet -- Ordering between different kinds of annotations is not significant, -- but ordering among annotations of the same kind is. Annotations @@ -93,78 +96,74 @@ :: T -> Bool -> RenderContext - -> Maybe TypeAnn - -> Maybe FieldAnn + -> AnnotationSet -> Doc -renderType t forceSingleLine pn mta mfa = - let rta = case mta of Just ta -> renderDoc doesntNeedParens ta; Nothing -> "" - rfa = case mfa of Just fa -> renderDoc doesntNeedParens fa; Nothing -> "" - recRenderer (Type tt ta) mfa' = - renderType tt forceSingleLine needsParens (Just ta) mfa' +renderType t forceSingleLine pn annSet = + let annDoc = renderDoc doesntNeedParens annSet + recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet' renderBranches d1 d2 = if forceSingleLine then (d1 <+> d2) else align $ softbreak <> (d1 <$> d2) in case t of - Tc ct -> wrapInParens pn $ renderCT ct :| [rta, rfa] - TKey -> wrapInParens pn $ "key" :| [rta, rfa] - TUnit -> wrapInParens pn $ "unit" :| [rta, rfa] - TSignature -> wrapInParens pn $ "signature" :| [rta, rfa] - TChainId -> wrapInParens pn $ "chain_id" :| [rta, rfa] - TOperation -> wrapInParens pn $ "operation" :| [rta, rfa] + Tc ct -> wrapInParens pn $ renderCT ct :| [annDoc] + TKey -> wrapInParens pn $ "key" :| [annDoc] + TUnit -> wrapInParens pn $ "unit" :| [annDoc] + TSignature -> wrapInParens pn $ "signature" :| [annDoc] + TChainId -> wrapInParens pn $ "chain_id" :| [annDoc] + TOperation -> wrapInParens pn $ "operation" :| [annDoc] TOption (Type t1 ta1) -> addParens pn $ - "option" <+> rta <+> rfa - <+> renderType t1 forceSingleLine needsParens (Just ta1) Nothing + "option" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1) TList (Type t1 ta1) -> addParens pn $ - "list" <+> rta <+> rfa - <+> renderType t1 forceSingleLine needsParens (Just ta1) Nothing + "list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1) TSet (Comparable ct1 ta1) -> addParens pn $ - "set" <+> rta <+> rfa - <+> renderType (Tc ct1) forceSingleLine needsParens (Just ta1) Nothing + "set" <+> annDoc <+> recRenderer (Tc ct1) (singleAnnSet ta1) TContract (Type t1 ta1) -> addParens pn $ - "contract" <+> rta <+> rfa - <+> renderType t1 forceSingleLine needsParens (Just ta1) Nothing + "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1) - TPair fa1 fa2 t1 t2 -> + TPair fa1 fa2 (Type t1 ta1) (Type t2 ta2) -> addParens pn $ - "pair" <+> rta <+> rfa <+> - (renderBranches - (recRenderer t1 (Just fa1)) (recRenderer t2 (Just fa2))) + "pair" <+> annDoc <+> + renderBranches + (recRenderer t1 $ fullAnnSet [ta1] [fa1] []) + (recRenderer t2 $ fullAnnSet [ta2] [fa2] []) - TOr fa1 fa2 t1 t2 -> + TOr fa1 fa2 (Type t1 ta1) (Type t2 ta2) -> addParens pn $ - "or" <+> rta <+> rfa <+> - (renderBranches - (recRenderer t1 (Just fa1)) (recRenderer t2 (Just fa2))) + "or" <+> annDoc <+> + renderBranches + (recRenderer t1 $ fullAnnSet [ta1] [fa1] []) + (recRenderer t2 $ fullAnnSet [ta2] [fa2] []) - TLambda t1 t2 -> + TLambda (Type t1 ta1) (Type t2 ta2) -> addParens pn $ - "lambda" <+> rta <+> rfa <+> - (renderBranches - (recRenderer t1 Nothing) (recRenderer t2 Nothing)) + "lambda" <+> annDoc <+> + renderBranches + (recRenderer t1 $ singleAnnSet ta1) + (recRenderer t2 $ singleAnnSet ta2) - TMap (Comparable ct1 ta1) t2 -> + TMap (Comparable ct1 ta1) (Type t2 ta2) -> addParens pn $ - "map" <+> rta <+> rfa <+> - (renderBranches - (renderType (Tc ct1) forceSingleLine needsParens (Just ta1) Nothing) - (recRenderer t2 Nothing)) + "map" <+> annDoc <+> + renderBranches + (recRenderer (Tc ct1) $ singleAnnSet ta1) + (recRenderer t2 $ singleAnnSet ta2) - TBigMap (Comparable ct1 ta1) t2 -> + TBigMap (Comparable ct1 ta1) (Type t2 ta2) -> addParens pn $ - "big_map" <+> rta <+> rfa <+> - (renderBranches - (renderType (Tc ct1) forceSingleLine needsParens (Just ta1) Nothing) - (recRenderer t2 Nothing)) + "big_map" <+> annDoc <+> + renderBranches + (recRenderer (Tc ct1) $ singleAnnSet ta1) + (recRenderer t2 $ singleAnnSet ta2) renderCT :: CT -> Doc renderCT = \case @@ -191,6 +190,8 @@ instance Buildable Comparable where build = buildRenderDoc +instance NFData Comparable + compToType :: Comparable -> Type compToType (Comparable ct tn) = Type (Tc ct) tn @@ -220,6 +221,8 @@ instance Buildable T where build = buildRenderDoc +instance NFData T + -- Comparable Sub-Type data CT = CInt @@ -235,6 +238,8 @@ instance Buildable CT where build = buildRenderDoc + +instance NFData CT pattern Tint :: T pattern Tint = Tc CInt diff --git a/src/Michelson/Untyped/Value.hs b/src/Michelson/Untyped/Value.hs --- a/src/Michelson/Untyped/Value.hs +++ b/src/Michelson/Untyped/Value.hs @@ -40,13 +40,19 @@ | ValueLambda (NonEmpty op) deriving stock (Eq, Show, Functor, Data, Generic) +instance NFData op => NFData (Value' op) + data Elt op = Elt (Value' op) (Value' op) deriving stock (Eq, Show, Functor, Data, Generic) +instance NFData op => NFData (Elt op) + -- | ByteString does not have an instance for ToJSON and FromJSON, to -- avoid orphan type class instances, make a new type wrapper around it. newtype InternalByteString = InternalByteString ByteString - deriving stock (Data, Eq, Show) + deriving stock (Data, Eq, Show, Generic) + +instance NFData InternalByteString unInternalByteString :: InternalByteString -> ByteString unInternalByteString (InternalByteString bs) = bs diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Morley/CLI.hs @@ -0,0 +1,145 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Utilities for parsing Morley types using @optparse-applicative@. + +module Morley.CLI + ( -- * Options + contractFileOption + , nowOption + , maxStepsOption + , dbPathOption + , txDataOption + , keyHashOption + , valueOption + , mutezOption + , addressOption + , onelineOption + , entrypointOption + , mTextOption + ) where + +import Options.Applicative (help, long, metavar, option, strOption, switch) +import qualified Options.Applicative as Opt + +import qualified Michelson.Parser as P +import Michelson.Runtime (TxData(..)) +import Michelson.Runtime.GState (genesisAddress) +import Michelson.Text (MText) +import Michelson.Untyped (EpName) +import qualified Michelson.Untyped as U +import Tezos.Address (Address) +import Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds) +import Tezos.Crypto +import Util.CLI +import Util.Named + +---------------------------------------------------------------------------- +-- These options are mostly specifications of 'mkCLOptionParser' +-- for concrete types (with more specific names). +---------------------------------------------------------------------------- + +-- | Parser for path to a contract code. +contractFileOption :: Opt.Parser FilePath +contractFileOption = strOption $ + long "contract" <> + metavar "FILEPATH" <> + help "Path to contract file" + +-- | Parser for the time returned by @NOW@ instruction. +nowOption :: Opt.Parser (Maybe Timestamp) +nowOption = optional $ option parser $ + long "now" <> + metavar "TIMESTAMP" <> + help "Timestamp that you want the runtime interpreter to use (default is now)" + where + parser = + (timestampFromSeconds <$> Opt.auto) <|> + Opt.maybeReader (parseTimestamp . toText) + +-- | Parser for gas limit on contract execution. +maxStepsOption :: Opt.Parser Word64 +maxStepsOption = mkCLOptionParser + (Just 100500) + (#name .! "max-steps") + (#help .! "Max steps that you want the runtime interpreter to use") + +-- | Parser for path to database with Morley state. +dbPathOption :: Opt.Parser FilePath +dbPathOption = Opt.strOption $ + long "db" <> + metavar "FILEPATH" <> + Opt.value "db.json" <> + help "Path to DB with data which is used instead of real blockchain data" <> + Opt.showDefault + +-- | Parser for transaction parameters. +txDataOption :: Opt.Parser TxData +txDataOption = + mkTxData + <$> addressOption (Just genesisAddress) + (#name .! "sender") (#help .! "Sender address") + <*> valueOption Nothing + (#name .! "parameter") (#help .! "Parameter of passed contract") + <*> mutezOption (Just minBound) + (#name .! "amount") (#help .! "Amount sent by a transaction") + <*> entrypointOption (#name .! "entrypoint") (#help .! "Entrypoint to call") + where + mkTxData :: Address -> U.Value -> Mutez -> EpName -> TxData + mkTxData addr param amount epName = + TxData + { tdSenderAddress = addr + , tdParameter = param + , tdEntrypoint = epName + , tdAmount = amount + } + +-- | Generic parser to read an option of 'KeyHash' type. +keyHashOption :: + Maybe KeyHash -> "name" :! String -> "help" :! String -> Opt.Parser KeyHash +keyHashOption = mkCLOptionParser + +-- | Generic parser to read an option of 'U.Value' type. +valueOption :: + Maybe U.Value -> "name" :! String -> "help" :! String -> Opt.Parser U.Value +valueOption = mkCLOptionParser + +-- | Generic parser to read an option of 'Mutez' type. +mutezOption :: + Maybe Mutez -> "name" :! String -> "help" :! String -> Opt.Parser Mutez +mutezOption = mkCLOptionParser + +-- | Generic parser to read an option of 'Address' type. +addressOption :: + Maybe Address -> "name" :! String -> "help" :! String -> Opt.Parser Address +addressOption = mkCLOptionParser + +-- | @--oneline@ flag. +onelineOption :: Opt.Parser Bool +onelineOption = switch ( + long "oneline" <> + help "Force single line output") + +-- | Generic parser to read an option of 'EpName' type. +entrypointOption :: "name" :! String -> "help" :! String -> Opt.Parser EpName +entrypointOption = mkCLOptionParser (Just U.DefEpName) + +-- | Generic parser to read an option of 'MText' type. +mTextOption :: + Maybe MText -> "name" :! String -> "help" :! String -> Opt.Parser MText +mTextOption = mkCLOptionParser + +---------------------------------------------------------------------------- +-- 'HasCLReader' orphan instances (better to avoid) +---------------------------------------------------------------------------- + +-- This instance uses parser which is not in the place where 'U.Value' +-- is defined, hence it is orphan. +instance HasCLReader U.Value where + getReader = eitherReader parseValue + where + parseValue :: String -> Either String U.Value + parseValue = + first (mappend "Failed to parse value: " . displayException) . + P.parseExpandValue . + toText + getMetavar = "MICHELSON VALUE" diff --git a/src/Morley/Micheline.hs b/src/Morley/Micheline.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Micheline.hs @@ -0,0 +1,64 @@ +-- | Module that provides type classes for converting to and from low-level +-- Micheline representation. +module Morley.Micheline + ( ToExpression (..) + , FromExpression (..) + ) where + +import Data.Sequence (fromList) +import Data.Singletons (pattern FromSing, Sing, SingI, withSingI) +import Tezos.Common.Binary (decode, encode) +import Tezos.V005.Micheline + (Expression(..), MichelinePrimAp(..), MichelinePrimitive(..)) + +import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT') +import Michelson.Interpret.Unpack (unpackInstr', unpackValue') +import Michelson.Typed + (FullContract(..), HasNoOp, Instr(..), Notes(..), T(..), Value, unParamNotes) +import Michelson.Typed.Scope (UnpackedValScope) +import Michelson.Untyped.Instr (ExpandedOp) + +-- | Type class that provides an ability to convert +-- something to Micheline Expression. +class ToExpression a where + toExpression :: a -> Expression + +instance ToExpression (Instr inp out) where + toExpression = decode . packCode' + +instance ToExpression T where + toExpression (FromSing (ts :: Sing t)) = + decode $ withSingI ts $ (packT' @t) + +instance SingI t => ToExpression (Notes t) where + toExpression = decode . packNotedT' + +instance (SingI t, HasNoOp t) => ToExpression (Value t) where + toExpression = decode . encodeValue' + +instance ToExpression (FullContract cp st) where + toExpression FullContract{..} = Expression_Seq $ fromList + [ Expression_Prim $ + MichelinePrimAp (MichelinePrimitive "parameter") + (fromList [toExpression $ unParamNotes $ fcParamNotesSafe]) + (fromList []) + , Expression_Prim $ + MichelinePrimAp (MichelinePrimitive "storage") + (fromList [toExpression $ fcStoreNotes]) + (fromList []) + , Expression_Prim $ + MichelinePrimAp (MichelinePrimitive "code") + (fromList [toExpression fcCode]) + (fromList []) + ] + +-- | Type class that provides the ability to convert +-- something from a Micheline Expression. +class FromExpression a where + fromExpression :: Expression -> Maybe a + +instance UnpackedValScope t => FromExpression (Value t) where + fromExpression = rightToMaybe . unpackValue' . ("\05" <>) . encode + +instance UnpackedValScope t => FromExpression [ExpandedOp] where + fromExpression = rightToMaybe . unpackInstr' . encode diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs --- a/src/Tezos/Address.hs +++ b/src/Tezos/Address.hs @@ -29,20 +29,25 @@ import Michelson.Text import Tezos.Crypto +import Util.CLI -- TODO: we should probably have a `Hash` type. -- | Hash of origination command for some contract. newtype ContractHash = ContractHash ByteString - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) +instance NFData ContractHash + -- | Data type corresponding to address structure in Tezos. data Address = KeyAddress KeyHash -- ^ `tz` address which is a hash of a public key. | ContractAddress ContractHash -- ^ `KT` address which corresponds to a callable contract. - deriving stock (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) +instance NFData Address + -- | Smart constructor for 'KeyAddress'. mkKeyAddress :: PublicKey -> Address mkKeyAddress = KeyAddress . hashKey @@ -97,8 +102,10 @@ -- ^ Address is not in Base58Check format. | ParseAddressBothFailed CryptoParseError ParseContractAddressError -- ^ Both address parsers failed with some error. - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData ParseAddressError + instance Buildable.Buildable ParseAddressError where build = \case @@ -132,8 +139,10 @@ = ParseContractAddressWrongBase58Check | ParseContractAddressWrongTag ByteString | ParseContractAddressWrongSize Int - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData ParseContractAddressError + instance Buildable.Buildable ParseContractAddressError where build = \case @@ -166,6 +175,14 @@ -- It was deduced empirically. contractAddressPrefix :: ByteString contractAddressPrefix = "\2\90\121" + +instance HasCLReader Address where + getReader = eitherReader parseAddrDo + where + parseAddrDo addr = + either (Left . mappend "Failed to parse address: " . pretty) Right $ + parseAddress $ toText addr + getMetavar = "ADDRESS" ---------------------------------------------------------------------------- -- Aeson instances diff --git a/src/Tezos/Core.hs b/src/Tezos/Core.hs --- a/src/Tezos/Core.hs +++ b/src/Tezos/Core.hs @@ -54,10 +54,12 @@ import Formatting.Buildable (Buildable(build)) import qualified Language.Haskell.TH.Quote as TH import Language.Haskell.TH.Syntax (liftData) +import qualified Options.Applicative as Opt import Test.QuickCheck (Arbitrary(..), vector) import Michelson.Text import Tezos.Crypto +import Util.CLI ---------------------------------------------------------------------------- -- Mutez @@ -75,6 +77,12 @@ -- This value was checked against the reference implementation. maxBound = Mutez 9223372036854775807 +instance HasCLReader Mutez where + getReader = maybe (readerError "Invalid mutez") pure . mkMutez =<< Opt.auto + getMetavar = "MUTEZ" + +instance NFData Mutez + -- | Safely create 'Mutez' checking for overflow. mkMutez :: Word64 -> Maybe Mutez mkMutez n @@ -159,6 +167,8 @@ { unTimestamp :: POSIXTime } deriving stock (Show, Eq, Ord, Data, Generic) +instance NFData Timestamp + timestampToSeconds :: Integral a => Timestamp -> a timestampToSeconds = round . unTimestamp {-# INLINE timestampToSeconds #-} @@ -250,7 +260,9 @@ -- signed data "in order to add extra replay protection between the main -- chain and the test chain". newtype ChainId = ChainIdUnsafe { unChainId :: ByteString } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +instance NFData ChainId -- | Construct chain ID from raw bytes. mkChainId :: ByteString -> Maybe ChainId diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs --- a/src/Tezos/Crypto.hs +++ b/src/Tezos/Crypto.hs @@ -87,6 +87,7 @@ import qualified Tezos.Crypto.P256 as P256 import qualified Tezos.Crypto.Secp256k1 as Secp256k1 import Tezos.Crypto.Util +import Util.CLI ---------------------------------------------------------------------------- -- Types, instances, conversions @@ -101,8 +102,10 @@ -- ^ Public key that uses the secp256k1 cryptographic curve. | PublicKeyP256 P256.PublicKey -- ^ Public key that uses the NIST P-256 cryptographic curve. - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData PublicKey + instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary @@ -115,8 +118,10 @@ -- ^ Secret key that uses the secp256k1 cryptographic curve. | SecretKeyP256 P256.SecretKey -- ^ Secret key that uses the NIST P-256 cryptographic curve. - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) +instance NFData SecretKey + -- | Deterministicaly generate a secret key from seed. -- Type of the key depends on seed length. detSecretKey :: HasCallStack => ByteString -> SecretKey @@ -160,8 +165,10 @@ -- ^ Signature that uses the NIST P-256 cryptographic curve. | SignatureGeneric ByteString -- ^ Generic signature for which curve is unknown. - deriving stock (Show) + deriving stock (Show, Generic) +instance NFData Signature + -- This instance slightly differs from the default one. If one -- signature is generic and the other one is not, they still may be -- equal if they have the same byte representation. @@ -341,19 +348,23 @@ = KeyHashEd25519 | KeyHashSecp256k1 | KeyHashP256 - deriving stock (Show, Eq, Ord, Bounded, Enum) + deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) instance Arbitrary KeyHashTag where arbitrary = elements [minBound .. ] +instance NFData KeyHashTag + -- | Blake2b_160 hash of a public key. data KeyHash = KeyHash { khTag :: KeyHashTag -- ^ We store which curve was used because it affects formatting. , khBytes :: ByteString -- ^ Hash itself. - } deriving stock (Show, Eq, Ord) + } deriving stock (Show, Eq, Ord, Generic) +instance NFData KeyHash + -- | Length of key hash in bytes (only hash itself, no tags, checksums -- or anything). keyHashLengthBytes :: Integral n => n @@ -396,3 +407,7 @@ KeyHashEd25519 -> "\006\161\159" KeyHashSecp256k1 -> "\006\161\161" KeyHashP256 -> "\006\161\164" + +instance HasCLReader KeyHash where + getReader = eitherReader (first pretty . parseKeyHash . toText) + getMetavar = "KEY_HASH" diff --git a/src/Tezos/Crypto/Ed25519.hs b/src/Tezos/Crypto/Ed25519.hs --- a/src/Tezos/Crypto/Ed25519.hs +++ b/src/Tezos/Crypto/Ed25519.hs @@ -49,16 +49,20 @@ -- | ED25519 public cryptographic key. newtype PublicKey = PublicKey { unPublicKey :: Ed25519.PublicKey - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +instance NFData PublicKey + -- | ED25519 secret cryptographic key. newtype SecretKey = SecretKey { unSecretKey :: Ed25519.SecretKey - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData SecretKey + -- | Deterministicaly generate a secret key from seed. detSecretKey :: ByteString -> SecretKey detSecretKey seed = SecretKey $ deterministic seed Ed25519.generateSecretKey @@ -73,10 +77,12 @@ -- | ED25519 cryptographic signature. newtype Signature = Signature { unSignature :: Ed25519.Signature - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) instance Arbitrary Signature where arbitrary = sign <$> arbitrary <*> (encodeUtf8 @String <$> arbitrary) + +instance NFData Signature ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Tezos/Crypto/P256.hs b/src/Tezos/Crypto/P256.hs --- a/src/Tezos/Crypto/P256.hs +++ b/src/Tezos/Crypto/P256.hs @@ -48,16 +48,20 @@ -- | P256 public cryptographic key. newtype PublicKey = PublicKey { unPublicKey :: ByteString - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +instance NFData PublicKey + -- | P256 secret cryptographic key. newtype SecretKey = SecretKey { unSecretKey :: ByteString - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData SecretKey + -- | Deterministicaly generate a secret key from seed. detSecretKey :: ByteString -> SecretKey detSecretKey seed = @@ -73,10 +77,12 @@ -- | P256 cryptographic signature. newtype Signature = Signature { unSignature :: ByteString - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) instance Arbitrary Signature where arbitrary = Signature . BS.pack <$> replicateM signatureLengthBytes arbitrary + +instance NFData Signature ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Tezos/Crypto/Secp256k1.hs b/src/Tezos/Crypto/Secp256k1.hs --- a/src/Tezos/Crypto/Secp256k1.hs +++ b/src/Tezos/Crypto/Secp256k1.hs @@ -33,7 +33,8 @@ import Crypto.Number.Serialize (i2ospOf_, os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Generate as ECC.Generate -import Crypto.PubKey.ECC.Types (Curve, CurveName(..), Point(..), curveSizeBits, getCurveByName) +import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), CurveCommon(..), CurvePrime(..) + ,Point(..), curveSizeBits, getCurveByName) import Crypto.Random (MonadRandom, drgNewSeed, seedFromInteger, withDRG) import Data.ByteArray (ByteArray, ByteArrayAccess) import qualified Data.ByteArray as BA @@ -64,7 +65,7 @@ -- public key. -- -- TODO (#18) remove it. - } deriving stock (Show) + } deriving stock (Show, Generic) -- TODO (#18): derive it instead once the above hack is removed. instance Eq PublicKey where @@ -73,11 +74,26 @@ instance Arbitrary PublicKey where arbitrary = toPublic <$> arbitrary +rnfCurve :: Curve -> () +rnfCurve cu = + case cu of + CurveF2m c -> rnf c + CurveFP (CurvePrime i (CurveCommon a b c d e)) -> + rnf (i, a, b, c, d, e) + +instance NFData PublicKey where + rnf (PublicKey (ECDSA.PublicKey cu q) bytes) + = rnfCurve cu `seq` rnf (bytes, q) + -- | Secp256k1 secret cryptographic key. newtype SecretKey = SecretKey { unSecretKey :: ECDSA.KeyPair - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) +instance NFData SecretKey where + rnf (SecretKey (ECDSA.KeyPair cu pp pn)) = + rnfCurve cu `seq` rnf (pp, pn) + -- | Deterministicaly generate a secret key from seed. detSecretKey :: ByteString -> SecretKey detSecretKey seed = deterministic seed $ detSecretKeyDo @@ -100,7 +116,7 @@ -- | Secp256k1 cryptographic signature. newtype Signature = Signature { unSignature :: ECDSA.Signature - } deriving stock (Show, Eq) + } deriving stock (Show, Eq, Generic) instance Arbitrary Signature where arbitrary = do @@ -109,6 +125,9 @@ return $ fst $ withDRG seed $ do sk <- detSecretKeyDo sign sk (one byteToSign) + +instance NFData Signature where + rnf (Signature (ECDSA.Signature a b)) = rnf a `seq` rnf b ---------------------------------------------------------------------------- -- Conversion to/from raw bytes (no checksums, tags or anything) diff --git a/src/Tezos/Crypto/Util.hs b/src/Tezos/Crypto/Util.hs --- a/src/Tezos/Crypto/Util.hs +++ b/src/Tezos/Crypto/Util.hs @@ -30,6 +30,9 @@ | CryptoParseUnexpectedLength Builder Int deriving stock (Show, Eq) +instance NFData CryptoParseError where + rnf = rnf @String . show + instance Buildable CryptoParseError where build = \case diff --git a/src/Util/CLI.hs b/src/Util/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Util/CLI.hs @@ -0,0 +1,166 @@ +-- | Utilities for command line options parsing +-- (we use @optparse-applicative@). +-- +-- Some names exported from this module are quite general when if you +-- do not assume @optparse-applicative@ usage, so consider using +-- explicit imports for it. + +module Util.CLI + ( -- * General helpers + maybeAddDefault + , outputOption + + -- * Named and type class based parsing + , HasCLReader (..) + , mkCLOptionParser + , mkCLOptionParserExt + , mkCLArgumentParser + , mkCLArgumentParserExt + , namedParser + + -- ** Helpers for defining 'HasCLReader' + , eitherReader + , readerError + ) where + +import qualified Data.Kind as Kind +import Fmt (Buildable, pretty) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Named (Name(..), arg) +import Options.Applicative + (eitherReader, help, long, metavar, option, readerError, showDefaultWith, strOption, value) +import qualified Options.Applicative as Opt + +import Util.Instances () +import Util.Named + +-- | Maybe add the default value and make sure it will be shown in +-- help message. +maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a +maybeAddDefault printer = maybe mempty addDefault + where + addDefault v = value v <> showDefaultWith printer + +-- | Parser for path to a file where output will be writen. +outputOption :: Opt.Parser (Maybe FilePath) +outputOption = optional . strOption $ + Opt.short 'o' <> + long "output" <> + metavar "FILEPATH" <> + help "Write output to the given file. If not specified, stdout is used." + +---------------------------------------------------------------------------- +-- Named parsing +---------------------------------------------------------------------------- + +-- | Supporting typeclass for 'namedParser'. +-- It specifies how a value should be parsed from command line. +-- Even though the main purpose of this class is to implement +-- helpers below, feel free to use it for other goals. +class HasCLReader a where + getReader :: Opt.ReadM a + -- | This string will be passed to the 'metavar' function, hence we + -- use 'String' type rather 'Text' (even though we use 'Text' almost + -- everywhere). + getMetavar :: String + +-- Let's add instances when the need arises. +-- The downside of having 'getMetavar' is that there is no instance +-- 'HasCLReader' for 'String' (aka 'FilePath') because we want +-- different metavars for filepaths and other strings. We can define +-- it as @FILEPATH@ because we normally use 'Text' for everything +-- else, but it still sounds a bit dangerous. + +instance HasCLReader Natural where + getReader = Opt.auto + getMetavar = "NATURAL NUMBER" + +instance HasCLReader Word64 where + getReader = Opt.auto + -- ↓ Same as for 'Natural', the user usually does not care whether + -- the number if bounded (reasonable values should fit anyway). + getMetavar = "NATURAL NUMBER" + +instance HasCLReader Integer where + getReader = Opt.auto + getMetavar = "INTEGER" + +instance HasCLReader Int where + getReader = Opt.auto + getMetavar = "INTEGER" + +instance HasCLReader Text where + getReader = Opt.str + getMetavar = "STRING" + +-- | Create a 'Opt.Parser' for a value using 'HasCLReader' instance +-- (hence @CL@ in the name). It uses reader and metavar from that +-- class, the rest should be supplied as arguments. +-- +-- We expect some common modifiers to be always provided, a list of +-- extra modifies can be provided as well. +mkCLOptionParser :: + forall a. (Buildable a, HasCLReader a) + => Maybe a + -> "name" :! String + -> "help" :! String + -> Opt.Parser a +mkCLOptionParser defValue name hInfo = + mkCLOptionParserExt defValue name hInfo [] + +-- | A more general version of 'mkCLOptionParser' which takes a list +-- of extra (not as widely used) modifiers. +mkCLOptionParserExt :: + forall a. (Buildable a, HasCLReader a) + => Maybe a + -> "name" :! String + -> "help" :! String + -> [Opt.Mod Opt.OptionFields a] + -> Opt.Parser a +mkCLOptionParserExt defValue (arg #name -> name) (arg #help -> hInfo) mods = + option getReader $ mconcat $ + metavar (getMetavar @a) : + long name : + help hInfo : + maybeAddDefault pretty defValue : + mods + +-- | Akin to 'mkCLOptionParser', but for arguments rather than options. +mkCLArgumentParser :: + forall a. (Buildable a, HasCLReader a) + => Maybe a + -> "help" :! String + -> Opt.Parser a +mkCLArgumentParser defValue hInfo = mkCLArgumentParserExt defValue hInfo [] + +-- | Akin to 'mkCLOptionParserExt', but for arguments rather than options. +mkCLArgumentParserExt :: + forall a. (Buildable a, HasCLReader a) + => Maybe a + -> "help" :! String + -> [Opt.Mod Opt.ArgumentFields a] + -> Opt.Parser a +mkCLArgumentParserExt defValue (arg #help -> hInfo) mods = + Opt.argument getReader $ mconcat $ + metavar (getMetavar @a) : + help hInfo : + maybeAddDefault pretty defValue : + mods + +-- | Create a 'Opt.Parser' for a value using its type-level name. +namedParser :: + forall (a :: Kind.Type) (name :: Symbol). + (Buildable a, HasCLReader a, KnownSymbol name) + => Maybe a + -> String + -> Opt.Parser (name :! a) +namedParser defValue hInfo = + option ((Name @name) <.!> getReader) $ + mconcat + [ long name + , metavar (getMetavar @a) + , help hInfo + , maybeAddDefault pretty (Name @name <.!> defValue) + ] + where + name = symbolVal (Proxy @name) diff --git a/src/Util/Exception.hs b/src/Util/Exception.hs --- a/src/Util/Exception.hs +++ b/src/Util/Exception.hs @@ -1,10 +1,20 @@ module Util.Exception - ( TextException (..) + ( -- * Common exceptions + TextException (..) + + -- * Better printing of exceptions + , displayUncaughtException ) where +import Control.Exception (throwIO) import Fmt (Buildable(..), pretty) +import System.Exit (ExitCode(..)) import qualified Text.Show +---------------------------------------------------------------------------- +-- Common exceptions +---------------------------------------------------------------------------- + data TextException = TextException Text instance Exception TextException @@ -13,3 +23,41 @@ instance Show TextException where show = pretty + +---------------------------------------------------------------------------- +-- Better printing of exceptions at executable-level +---------------------------------------------------------------------------- + +newtype DisplayExceptionInShow = DisplayExceptionInShow SomeException + +instance Show DisplayExceptionInShow where + show (DisplayExceptionInShow se) = displayException se + +instance Exception DisplayExceptionInShow + +-- | Customise default uncaught exception handling. The problem with +-- the default handler is that it uses `show` to display uncaught +-- exceptions, but `displayException` may provide more reasonable +-- output. We do not modify uncaught exception handler, but simply +-- wrap uncaught exceptions (only synchronous ones) into +-- 'DisplayExceptionInShow'. +-- +-- Some exceptions (currently we are aware only of 'ExitCode') are +-- handled specially by default exception handler, so we don't wrap +-- them. +displayUncaughtException :: IO () -> IO () +displayUncaughtException = mapIOExceptions wrapUnlessExitCode + where + -- We can't use `mapException` here, because it only works with + -- exceptions inside pure values, not with `IO` exceptions. + -- Note: it doesn't catch async exceptions. + mapIOExceptions :: (SomeException -> SomeException) -> IO a -> IO a + mapIOExceptions f action = action `catchAny` (throwIO . f) + + -- We don't wrap `ExitCode` because it seems to be handled specially. + -- Application exit code depends on the value stored in `ExitCode`. + wrapUnlessExitCode :: SomeException -> SomeException + wrapUnlessExitCode e = + case fromException @ExitCode e of + Just _ -> e + Nothing -> toException $ DisplayExceptionInShow e diff --git a/src/Util/Label.hs b/src/Util/Label.hs new file mode 100644 --- /dev/null +++ b/src/Util/Label.hs @@ -0,0 +1,44 @@ +-- | Definition of the Label type and utilities +module Util.Label + ( -- * Definitions + Label (..) + + -- * Utilities + , labelToText + + -- * Re-exports + , IsLabel (..) + ) where + +import Fmt (Buildable(..), pretty) +import GHC.OverloadedLabels (IsLabel(..)) +import Text.Show(Show(..)) + +import Util.TypeLits + +-------------------------------------------------------------------------------- +-- Definitions +-------------------------------------------------------------------------------- + +-- | Proxy for a label type that includes the 'KnownSymbol' constraint +data Label (name :: Symbol) where + Label :: KnownSymbol name => Label name + +deriving instance Eq (Label name) + +instance Show (Label name) where + show label = "Label " <> pretty label + +instance (KnownSymbol name, s ~ name) => IsLabel s (Label name) where + fromLabel = Label + +instance Buildable (Label name) where + build Label = build $ symbolVal (Proxy @name) + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Utility function to get the 'Text' representation of a 'Label' +labelToText :: Label name -> Text +labelToText = pretty diff --git a/src/Util/Markdown.hs b/src/Util/Markdown.hs --- a/src/Util/Markdown.hs +++ b/src/Util/Markdown.hs @@ -2,6 +2,8 @@ module Util.Markdown ( Markdown , HeaderLevel (..) + , Anchor (..) + , ToAnchor (..) , nextHeaderLevel , mdHeader , mdSubsection @@ -32,6 +34,23 @@ -- | Level of header, starting from 1. newtype HeaderLevel = HeaderLevel Int +-- | Anchor with given text. +newtype Anchor = Anchor { unAnchor :: Text } + +instance IsString Anchor where + -- Avoiding collision with names assigned by autodoc engine + fromString = Anchor . fromString . ("manual-" <>) + +-- | Picking anchor for various things. +class ToAnchor anchor where + toAnchor :: anchor -> Anchor + +instance ToAnchor Anchor where + toAnchor = id + +instance ToAnchor Text where + toAnchor = Anchor + nextHeaderLevel :: HeaderLevel -> HeaderLevel nextHeaderLevel (HeaderLevel l) = HeaderLevel (l + 1) @@ -71,16 +90,16 @@ c : s -> build (toText [c]) <> mdEscapeAnchorS s -- | Turn text into valid anchor. Human-readability is not preserved. -mdEscapeAnchor :: Text -> Markdown -mdEscapeAnchor = mdEscapeAnchorS . toString +mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown +mdEscapeAnchor = mdEscapeAnchorS . toString . unAnchor . toAnchor mdRef :: Markdown -> Markdown -> Markdown mdRef txt ref = "[" <> txt <> "](" <> ref <> ")" -mdLocalRef :: Markdown -> Text -> Markdown +mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown mdLocalRef txt anchor = mdRef txt ("#" <> mdEscapeAnchor anchor) -mdAnchor :: Text -> Markdown +mdAnchor :: ToAnchor anchor => anchor -> Markdown mdAnchor name = " mdEscapeAnchor name <> "\">\n\n" mdSeparator :: Markdown @@ -105,6 +124,8 @@ "" -- | Quasi quoter for Markdown. +-- +-- This supports interpolation via @#{expression}@ syntax. md :: QuasiQuoter md = QuasiQuoter { quoteExp = \s -> [|fromString @Markdown $ unindent $(quoteExp Interpolate.i s) |] diff --git a/src/Util/Named.hs b/src/Util/Named.hs --- a/src/Util/Named.hs +++ b/src/Util/Named.hs @@ -10,9 +10,10 @@ , (<.?>) , ApplyNamedFunctor , NamedInner + , KnownNamedFunctor (..) ) where -import Control.Lens (Wrapped(..), iso) +import Control.Lens (Iso', Wrapped(..), iso) import Data.Aeson (FromJSON, ToJSON) import Data.Data (Data) import qualified Data.Kind as Kind @@ -20,6 +21,7 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import Named ((:!), (:?), Name, NamedF(..)) import qualified Text.Show +import Util.Label (Label) (.!) :: Name name -> a -> NamedF Identity a name (.!) _ = ArgF . Identity @@ -39,6 +41,21 @@ type family NamedInner (n :: Kind.Type) where NamedInner (NamedF f a _) = ApplyNamedFunctor f a + +-- | Isomorphism between named entity and the entity itself wrapped into the +-- respective functor. +namedFL :: Label name -> Iso' (NamedF f a name) (f a) +namedFL _ = iso (\(ArgF x) -> x) ArgF + +class KnownNamedFunctor f where + -- | Isomorphism between named entity and the entity itself. + namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a) + +instance KnownNamedFunctor Identity where + namedL l = namedFL l . _Wrapped' + +instance KnownNamedFunctor Maybe where + namedL l = namedFL l ---------------------------------------------------------------------------- -- Instances diff --git a/src/Util/Peano.hs b/src/Util/Peano.hs --- a/src/Util/Peano.hs +++ b/src/Util/Peano.hs @@ -39,10 +39,16 @@ , IsLongerOrSameLength , LongerOrSameLength , RequireLongerOrSameLength + + -- * Length constraints 'Dict'ionaries + , requireLongerThan + , requireLongerOrSameLength ) where +import Data.Constraint (Dict (..)) import Data.Singletons (Sing, SingI(..)) import Data.Type.Bool (If) +import Data.Vinyl (Rec(..)) import Data.Vinyl.TypeLevel (Nat(..), RLength) import GHC.TypeLits (ErrorMessage(..), TypeError) import GHC.TypeNats (type (+), type (-)) @@ -87,6 +93,9 @@ deriving stock instance Show (Sing (n :: Nat)) deriving stock instance Eq (Sing (n :: Nat)) +instance NFData (Sing (n :: Nat)) where + rnf SZ = () + rnf (SS n) = rnf n instance SingI 'Z where sing = SZ @@ -222,3 +231,27 @@ RequireLongerOrSameLength (l :: [k]) (a :: Peano) instance RequireLongerOrSameLength' l a => LongerOrSameLength l a => RequireLongerOrSameLength l a + +---------------------------------------------------------------------------- +-- Length constraints 'Dict'ionaries +---------------------------------------------------------------------------- + +requireLongerThan + :: Rec any stk + -> Sing n + -> Maybe (Dict (RequireLongerThan stk n)) +requireLongerThan RNil _ = Nothing +requireLongerThan (_ :& _xs) SZ = Just Dict +requireLongerThan (_ :& xs) (SS n) = do + Dict <- requireLongerThan xs n + return Dict + +requireLongerOrSameLength + :: Rec any stk + -> Sing n + -> Maybe (Dict (RequireLongerOrSameLength stk n)) +requireLongerOrSameLength _ SZ = Just Dict +requireLongerOrSameLength RNil (SS _) = Nothing +requireLongerOrSameLength (_ :& xs) (SS n) = do + Dict <- requireLongerOrSameLength xs n + return Dict diff --git a/src/Util/Positive.hs b/src/Util/Positive.hs --- a/src/Util/Positive.hs +++ b/src/Util/Positive.hs @@ -17,8 +17,10 @@ -- We define our own datatype in order to have 'Data' instance for it, -- which can not be derived for third-party types without exported constructor. newtype Positive = PositiveUnsafe { unPositive :: Natural } - deriving stock (Eq, Ord, Data) + deriving stock (Eq, Ord, Data, Generic) deriving newtype (Show, Buildable, ToJSON, FromJSON) + +instance NFData Positive mkPositive :: (Integral i, Buildable i) => i -> Either Text Positive mkPositive a diff --git a/src/Util/TH.hs b/src/Util/TH.hs new file mode 100644 --- /dev/null +++ b/src/Util/TH.hs @@ -0,0 +1,40 @@ +module Util.TH (deriveGADTNFData) where + +import Language.Haskell.TH + +-- | Generates an NFData instance for a GADT. /Note:/ This will not generate +-- additional constraints to the generated instance if those are required. +deriveGADTNFData :: Name -> Q [Dec] +deriveGADTNFData name = do + (TyConI (DataD _ dataName vars _ cons _)) <- reify name + let + getNameFromVar (PlainTV n) = n + getNameFromVar (KindedTV n _) = n + convertTyVars orig = foldr (\a b -> AppT b . VarT $ getNameFromVar a) orig vars + + -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff" + -- into a list of tuples of constructor names and their data + unfoldConstructor (GadtC cs bangs _) = map (,bangs) cs + unfoldConstructor (ForallC _ _ c) = unfoldConstructor c + unfoldConstructor _ = fail "Non GADT constructors are not supported." + + -- Constructs a clause "rnf (ConName a1 a2 ...) = rnf (a1, a2, ...) + makeClauses (conName, bangs) = do + varNames <- traverse (\_ -> newName "a") bangs + let rnfExp e = AppE (VarE $ mkName "rnf") e + return $ + (Clause + [ConP conName $ map VarP varNames] + (NormalB (rnfExp . TupE $ map VarE varNames)) + [] + ) + + makeInstance clauses = + InstanceD + Nothing + [] + (AppT (ConT $ mkName "NFData") (convertTyVars $ ConT dataName)) + [FunD (mkName "rnf") clauses] + + clauses <- traverse makeClauses $ cons >>= unfoldConstructor + return [makeInstance clauses] diff --git a/src/Util/Text.hs b/src/Util/Text.hs --- a/src/Util/Text.hs +++ b/src/Util/Text.hs @@ -1,5 +1,6 @@ module Util.Text ( headToLower + , surround ) where import Data.Char (toLower) @@ -12,3 +13,6 @@ headToLower txt = case T.uncons txt of Nothing -> error "Empty text" Just (c, cs) -> T.cons (toLower c) cs + +surround :: Semigroup a => a -> a -> a -> a +surround pre post content = pre <> content <> post diff --git a/src/Util/Type.hs b/src/Util/Type.hs --- a/src/Util/Type.hs +++ b/src/Util/Type.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE QuantifiedConstraints #-} -- | General type utilities. module Util.Type @@ -22,18 +23,22 @@ , KList (..) , RSplit , rsplit + , Some1 (..) + , recordToSomeList , reifyTypeEquality ) where +import Data.Constraint ((:-)(..), Dict(..)) import Data.Vinyl.Core (Rec (..)) +import qualified Data.Vinyl.Functor as Vinyl +import Data.Vinyl.Recursive (recordToList, rmap) import Data.Vinyl.TypeLevel (type (++)) import qualified Data.Kind as Kind -import Data.Type.Bool (Not, type (&&), If) -import Unsafe.Coerce (unsafeCoerce) -import Data.Constraint ((:-)(..), Dict (..)) +import Data.Type.Bool (type (&&), If, Not) import Data.Type.Equality (type (==)) -import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..)) +import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) +import Unsafe.Coerce (unsafeCoerce) type family IsElem (a :: k) (l :: [k]) :: Bool where IsElem _ '[] = 'False @@ -141,3 +146,12 @@ KCons{} -> \(x :& r) -> let (x1, r1) = rsplit r in (x :& x1, r1) + +-- | A value of type parametrized with /some/ type parameter. +data Some1 (f :: k -> Kind.Type) = + forall a. Some1 (f a) + +deriving stock instance (forall a. Show (f a)) => Show (Some1 f) + +recordToSomeList :: Rec f l -> [Some1 f] +recordToSomeList = recordToList . rmap (Vinyl.Const . Some1) diff --git a/src/Util/TypeLits.hs b/src/Util/TypeLits.hs --- a/src/Util/TypeLits.hs +++ b/src/Util/TypeLits.hs @@ -5,6 +5,7 @@ ( Symbol , KnownSymbol , AppendSymbol + , symbolVal , symbolValT , symbolValT' diff --git a/src/Util/Typeable.hs b/src/Util/Typeable.hs --- a/src/Util/Typeable.hs +++ b/src/Util/Typeable.hs @@ -10,6 +10,7 @@ , eqExt , compareExt , castIgnoringPhantom + , eqTypeIgnoringPhantom -- * Re-exports , (:~:) (..) @@ -145,3 +146,15 @@ return (coerce x) type family DummyPhantomType :: k where + +-- | Match given type against another type of @* -> *@ kind without caring +-- about its type argument. +eqTypeIgnoringPhantom + :: forall c x r. + (Typeable x, Typeable c) + => (forall a. Typeable a => (c a :~: x) -> Proxy a -> r) -> Maybe r +eqTypeIgnoringPhantom cont = do + Refl.App x1Rep xArgRep <- pure $ Refl.typeRep @x + let cRep = Refl.typeRep @c + Refl.HRefl <- Refl.eqTypeRep x1Rep cRep + return $ Refl.withTypeable xArgRep (cont Refl Proxy) diff --git a/test/Test/Analyzer.hs b/test/Test/Analyzer.hs --- a/test/Test/Analyzer.hs +++ b/test/Test/Analyzer.hs @@ -30,7 +30,7 @@ str3 :: MText str3 = [mt|bb|] -sample :: T.Contract ('T.Tc 'CString) ('T.Tc 'CString) +sample :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString) sample = CAR `Seq` DUP `Seq` pushStr str3 `Seq` diff --git a/test/Test/Ext.hs b/test/Test/Ext.hs --- a/test/Test/Ext.hs +++ b/test/Test/Ext.hs @@ -13,17 +13,19 @@ import Michelson.Test (concatTestTrees, testTreesWithTypedContract) import Michelson.Test.Dummy (dummyContractEnv) import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheck, typeCheckExt, typeCheckList) -import Michelson.Typed (CValue(..), epcPrimitive, withUType) +import Michelson.Typed (pattern AsUType, CValue(..), epcPrimitive) import qualified Michelson.Typed as T import Michelson.Untyped (CT(..), ExpandedExtInstr, ExtInstrAbstract(..), StackTypePattern(..), T(..), TyVar(..), Type(..), ann, noAnn) +import Test.Util.Contracts + test_PRINT_and_TEST_ASSERT :: IO [TestTree] test_PRINT_and_TEST_ASSERT = concatTestTrees - [ testTreesWithTypedContract "contracts/testassert_square.mtz" $ + [ testTreesWithTypedContract (inContractsDir "testassert_square.mtz") $ testAssertSquareImpl - , testTreesWithTypedContract "contracts/testassert_square2.mtz" $ + , testTreesWithTypedContract (inContractsDir "testassert_square2.mtz") $ testAssertSquareImpl ] where @@ -43,7 +45,7 @@ let check (a, InterpreterState s _) = if corr then isRight a && s == MorleyLogs ["Area is " <> show area'] else isLeft a && s == MorleyLogs ["Sides are " <> show x' <> " x " <> show y'] - interpret contract epcPrimitive (T.VPair (x', y')) T.VUnit dummyContractEnv `shouldSatisfy` check + interpret (T.fcCode contract) epcPrimitive (T.VPair (x', y')) T.VUnit dummyContractEnv `shouldSatisfy` check test_STACKTYPE :: [TestTree] test_STACKTYPE = @@ -79,9 +81,9 @@ convertToHST :: [Type] -> SomeHST convertToHST [] = SomeHST SNil - convertToHST (t : ts) = withUType t $ \((sing :: T.Sing t), (nt :: T.Notes t)) -> + convertToHST (AsUType nt : ts) = case convertToHST ts of - SomeHST is -> SomeHST ((sing, nt, noAnn) ::& is) + SomeHST is -> SomeHST ((nt, noAnn) ::& is) nh (ni, si) = runTypeCheck (Type TKey noAnn) mempty $ usingReaderT def $ typeCheckExt typeCheckList ni si diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -17,35 +17,49 @@ , test_split_string_simple , test_complex_strings , test_contract_instr_on_implicit - , test_Entry_points_lookup - , test_Entry_points_calling + , test_map_preserve_stack ) where -import qualified Data.Map as Map -import Data.Singletons (SingI) import Fmt (pretty) +import System.FilePath (()) import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldSatisfy) import Test.HUnit (assertFailure) import Test.QuickCheck (Property, label, (.&&.), (===)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck (testProperty) -import Util.Named ((.!)) import Michelson.Interpret (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps, interpret) import Michelson.Test + (ContractPropValidator, concatTestTrees, contractProp, testTreesWithTypedContract, validateStorageIs) +import Michelson.Test.Dummy (dummyContractEnv) +import Michelson.Test.Util (failedProp) +import Michelson.Test.Unit import Michelson.Text import Michelson.Typed (CT(..), CValue(..), IsoValue(..), T(..), epcPrimitive) import qualified Michelson.Typed as T -import qualified Michelson.Untyped as U import Tezos.Address -import Tezos.Core import Tezos.Crypto +import Test.Util.Contracts + +interpretSimple + :: forall cp st. + ( IsoValue cp, IsoValue st + , T.ParameterScope (ToT cp) + , T.ForbidOr (ToT cp) + ) + => T.FullContract (ToT cp) (ToT st) + -> cp + -> st + -> ContractReturn (ToT st) +interpretSimple contract cp st = + interpret (T.fcCode contract) epcPrimitive (toVal cp) (toVal st) dummyContractEnv + test_basic5 :: IO [TestTree] test_basic5 = - testTreesWithTypedContract "contracts/basic5.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "basic5.tz") $ \contract -> pure [ testCase "Basic test" $ contractProp @() @[Integer] contract (validateStorageIs [13 :: Integer, 100]) dummyContractEnv () [1] @@ -53,7 +67,7 @@ test_increment :: IO [TestTree] test_increment = - testTreesWithTypedContract "contracts/increment.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "increment.tz") $ \contract -> pure [ testCase "Basic test" $ contractProp @() @Integer contract (validateStorageIs @Integer 24) dummyContractEnv () 23 @@ -61,31 +75,31 @@ test_fail :: IO [TestTree] test_fail = - testTreesWithTypedContract "contracts/tezos_examples/macros/fail.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "tezos_examples/macros/fail.tz") $ \contract -> pure [ testCase "Fail test" $ - interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv + interpretSimple contract () () `shouldSatisfy` (isLeft . fst) ] test_mutez_add_overflow :: IO [TestTree] test_mutez_add_overflow = - testTreesWithTypedContract "contracts/mutez_add_overflow.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "mutez_add_overflow.tz") $ \contract -> pure [ testCase "Mutez add overflow test" $ - interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv + interpretSimple contract () () `shouldSatisfy` (isLeft . fst) ] test_mutez_sub_overflow :: IO [TestTree] test_mutez_sub_overflow = - testTreesWithTypedContract "contracts/mutez_sub_underflow.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "mutez_sub_underflow.tz") $ \contract -> pure [ testCase "Mutez sub underflow test" $ - interpret contract epcPrimitive T.VUnit T.VUnit dummyContractEnv + interpretSimple contract () () `shouldSatisfy` (isLeft . fst) ] test_basic1 :: IO [TestTree] test_basic1 = - testTreesWithTypedContract "contracts/basic1.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "basic1.tz") $ \contract -> pure [ testProperty "Random check" $ \input -> contractProp @_ @[Integer] contract (validateBasic1 input) dummyContractEnv () input @@ -93,36 +107,36 @@ test_lsl :: IO [TestTree] test_lsl = - testTreesWithTypedContract "contracts/lsl.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "lsl.tz") $ \contract -> pure [ testCase "LSL shouldn't overflow test" $ contractProp @Natural @Natural contract (validateStorageIs @Natural 20) dummyContractEnv 5 2 , testCase "LSL should overflow test" $ - interpret contract epcPrimitive (toVal @Natural 5) (toVal @Natural 257) dummyContractEnv + interpretSimple contract (5 :: Natural) (257 :: Natural) `shouldSatisfy` (isLeft . fst) ] test_lsr :: IO [TestTree] test_lsr = - testTreesWithTypedContract "contracts/lsr.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "lsr.tz") $ \contract -> pure [ testCase "LSR shouldn't underflow test" $ contractProp @Natural @Natural contract (validateStorageIs @Natural 3) dummyContractEnv 30 3 , testCase "LSR should underflow test" $ - interpret contract epcPrimitive (toVal @Natural 1000) (toVal @Natural 257) dummyContractEnv + interpretSimple contract (1000 :: Natural) (257 :: Natural) `shouldSatisfy` (isLeft . fst) ] test_FAILWITH :: IO [TestTree] test_FAILWITH = concatTestTrees - [ testTreesWithTypedContract "contracts/failwith_message.tz" $ \contract -> + [ testTreesWithTypedContract (contractsDir "failwith_message.tz") $ \contract -> pure [ testCase "Failwith message test" $ do let msg = [mt|An error occurred.|] :: MText contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv msg () ] - , testTreesWithTypedContract "contracts/failwith_message2.tz" $ \contract -> + , testTreesWithTypedContract (contractsDir "failwith_message2.tz") $ \contract -> pure [ testCase "Conditional failwith message test" $ do let msg = [mt|An error occurred.|] @@ -137,26 +151,26 @@ test_STEPS_TO_QUOTA :: IO [TestTree] test_STEPS_TO_QUOTA = concatTestTrees - [ testTreesWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract -> + [ testTreesWithTypedContract (contractsDir "deprecated/steps_to_quota_test1.tz") $ \contract -> pure [ testCase "Amount of steps should decrease (1)" $ do validateStepsToQuotaTest - (interpret contract epcPrimitive T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 4 + (interpretSimple contract () (0 :: Natural)) 4 ] - , testTreesWithTypedContract "contracts/steps_to_quota_test2.tz" $ \contract -> + , testTreesWithTypedContract (contractsDir "deprecated/steps_to_quota_test2.tz") $ \contract -> pure [ testCase "Amount of steps should decrease (2)" $ do validateStepsToQuotaTest - (interpret contract epcPrimitive T.VUnit (T.VC (CvNat 0)) dummyContractEnv) 8 + (interpretSimple contract () (0 :: Natural)) 8 ] ] test_gas_exhaustion :: IO [TestTree] test_gas_exhaustion = - testTreesWithTypedContract "contracts/gas_exhaustion.tz" $ \contract -> pure + testTreesWithTypedContract (contractsDir "gas_exhaustion.tz") $ \contract -> pure [ testCase "Contract should fail due to gas exhaustion" $ do - let dummyStr = toVal [mt|x|] - case fst $ interpret contract epcPrimitive dummyStr dummyStr dummyContractEnv of + let dummyStr = [mt|x|] + case fst $ interpretSimple contract dummyStr dummyStr of Right _ -> assertFailure "expecting contract to fail" Left MichelsonGasExhaustion -> pass Left _ -> assertFailure "expecting another failure reason" @@ -164,7 +178,7 @@ test_add1_list :: IO [TestTree] test_add1_list = - testTreesWithTypedContract "contracts/tezos_examples/attic/add1_list.tz" $ \contract -> + testTreesWithTypedContract (contractsDir "tezos_examples/attic/add1_list.tz") $ \contract -> let doValidate :: [Integer] -> ContractPropValidator (ToT [Integer]) Property @@ -181,7 +195,7 @@ test_Sum_types :: IO [TestTree] test_Sum_types = concatTestTrees - [ testTreesWithTypedContract "contracts/union.mtz" $ \contract -> pure + [ testTreesWithTypedContract (contractsDir "union.mtz") $ \contract -> pure [ testGroup "union.mtz: union corresponds to Haskell types properly" $ let caseTest param = contractProp contract validateSuccess dummyContractEnv param () @@ -193,7 +207,7 @@ , testCase "Case 5" $ caseTest (Case5 [[mt|q|]]) ] ] - , testTreesWithTypedContract "contracts/case.mtz" $ \contract -> pure + , testTreesWithTypedContract (contractsDir "case.mtz") $ \contract -> pure [ testGroup "CASE instruction" $ let caseTest param expectedStorage = contractProp contract (validateStorageIs @MText expectedStorage) @@ -206,7 +220,7 @@ , testCase "Case 5" $ caseTest (Case5 $ [[mt|a|], [mt|b|]]) [mt|ab|] ] ] - , testTreesWithTypedContract "contracts/tag.mtz" $ \contract -> pure + , testTreesWithTypedContract (contractsDir "tag.mtz") $ \contract -> pure [ testCase "TAG instruction" $ let expected = mconcat [[mt|unit|], [mt|o|], [mt|ab|], [mt|nat|], [mt|int|]] in contractProp contract (validateStorageIs expected) dummyContractEnv () [mt||] @@ -215,18 +229,18 @@ test_Product_types :: IO [TestTree] test_Product_types = concatTestTrees - [ testTreesWithTypedContract "contracts/access.mtz" $ \contract -> pure + [ testTreesWithTypedContract (contractsDir "access.mtz") $ \contract -> pure [ testCase "ACCESS instruction" $ contractProp @Tuple1 contract validateSuccess dummyContractEnv (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|]]) () ] - , testTreesWithTypedContract "contracts/set.mtz" $ \contract -> pure + , testTreesWithTypedContract (contractsDir "set.mtz") $ \contract -> pure [ testCase "SET instruction" $ let expected = (2, [mt|za|], Just [mt|wa|], Right [mt|ya|], [[mt|ab|]]) :: Tuple1 in contractProp @_ @Tuple1 contract (validateStorageIs expected) dummyContractEnv () (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|], [mt|b|]]) ] - , testTreesWithTypedContract "contracts/construct.mtz" $ \contract -> pure + , testTreesWithTypedContract (contractsDir "construct.mtz") $ \contract -> pure [ testCase "CONSTRUCT instruction" $ let expected = (1, [mt|a|], Just [mt|b|], Left [mt|q|], []) :: Tuple1 in contractProp @_ @Tuple1 contract (validateStorageIs expected) @@ -236,8 +250,8 @@ test_split_bytes :: IO [TestTree] test_split_bytes = - testTreesWithTypedContract "contracts/tezos_examples/opcodes/split_bytes.tz" $ \contract -> - pure + testTreesWithTypedContract (contractsDir "tezos_examples/opcodes/split_bytes.tz") $ + \contract -> pure [ testCase "splits given byte sequence into parts" $ let expected = ["\11", "\12", "\13"] :: [ByteString] in contractProp contract (validateStorageIs expected) dummyContractEnv @@ -246,7 +260,7 @@ test_split_string_simple :: IO [TestTree] test_split_string_simple = - testTreesWithTypedContract "contracts/split_string_simple.tz" $ \contract -> + testTreesWithTypedContract (contractsDir "split_string_simple.tz") $ \contract -> pure [ testCase "applies SLICE instruction" $ do let @@ -270,7 +284,7 @@ test_complex_strings :: IO [TestTree] test_complex_strings = - testTreesWithTypedContract "contracts/complex_strings.tz" $ \contract -> + testTreesWithTypedContract (contractsDir "complex_strings.tz") $ \contract -> pure [ testCase "ComplexString" $ contractProp contract @@ -291,8 +305,8 @@ test_contract_instr_on_implicit :: IO [TestTree] test_contract_instr_on_implicit = - testTreesWithTypedContract "contracts/contract_instr_unit.tz" $ \contractGood -> - testTreesWithTypedContract "contracts/contract_instr_nonunit.tz" $ \contractBad -> + testTreesWithTypedContract (contractsDir "contract_instr_unit.tz") $ \contractGood -> + testTreesWithTypedContract (contractsDir "contract_instr_nonunit.tz") $ \contractBad -> pure [ testCase "CONTRACT instruction succeeds on implicit accounts" $ contractProp contractGood validateSuccess dummyContractEnv addr () @@ -304,106 +318,22 @@ where addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf" --- TODO [TM-280] Move to separate module -test_Entry_points_lookup :: IO [TestTree] -test_Entry_points_lookup = - testTreesWithTypedContract (dir <> "call1.mtz") $ \call1 -> - testTreesWithTypedContract (dir <> "call2.mtz") $ \call2 -> - testTreesWithTypedContract (dir <> "call3.mtz") $ \call3 -> - testTreesWithTypedContract (dir <> "call4.mtz") $ \call4 -> - testTreesWithTypedContract (dir <> "call5.mtz") $ \call5 -> - testTreesWithTypedContract (dir <> "call6.mtz") $ \call6 -> - testTreesWithTypedContract (dir <> "call7.mtz") $ \call7 -> +-- | This test creates a map of two items and then converts them into a list +-- with @MAP@ primitive, counting the number of items along the way. +-- +-- See https://gitlab.com/morley-framework/morley/-/issues/123 +test_map_preserve_stack :: IO [TestTree] +test_map_preserve_stack = + testTreesWithTypedContract (contractsDir "map_preserve_stack.tz") $ \contract -> pure - [ testGroup "Calling contract without default entrypoint" - [ testCase "Calling default entrypoint refers to the root" $ - checkProp call1 validateSuccess (addr "simple") - , testCase "Calling some entrypoint refers this entrypoint" $ - checkProp call7 validateSuccess (addr "simple") - ] - , testGroup "Calling contract with default entrypoint" - [ testCase "Calling default entrypoint works" $ - checkProp call2 validateSuccess (addr "def") - ] - , testGroup "Common failures" - [ testCase "Fails on type mismatch" $ - checkProp call1 validateFailure (addr "def") - , testCase "Fails on entrypoint not found" $ - checkProp call3 validateFailure (addr "simple") - ] - , testGroup "Referring entrypoints groups" - [ testCase "Can refer entrypoint group" $ - checkProp call4 validateSuccess (addr "complex") - , testCase "Works with annotations" $ - checkProp call5 validateSuccess (addr "complex") - , testCase "Does not work on annotations mismatch in 'contract' type argument" $ - checkProp call6 validateFailure (addr "complex") - ] + [ testCase "MAP preserves deep stack modifications (#123)" $ + contractProp @() @([Integer], Integer) contract + (validateStorageIs @([Integer], Integer) ([257, 43], 2)) + dummyContractEnv () ([], 0) ] - where - checkProp contract validator callee = - contractProp @Address @() - contract validator - dummyContractEnv{ ceContracts = Map.fromList env } - callee () - validateFailure = validateMichelsonFailsWith () - dir = "contracts/entrypoints/" - contractSimpleTy = - U.Type (U.TOr (U.ann "a") (U.ann "b") (U.Type U.Tint U.noAnn) (U.Type U.Tnat U.noAnn)) - U.noAnn - contractComplexTy = - U.Type (U.TOr (U.ann "s") (U.ann "t") (U.Type U.Tstring U.noAnn) contractSimpleTy) - U.noAnn - contractWithDefTy = - U.Type (U.TOr (U.ann "a") (U.ann "default") (U.Type U.Tnat U.noAnn) (U.Type U.Tstring U.noAnn)) - U.noAnn - addr = mkContractAddressRaw - env = - [ (mkContractHashRaw "simple", contractSimpleTy) - , (mkContractHashRaw "complex", contractComplexTy) - , (mkContractHashRaw "def", contractWithDefTy) - ] - -test_Entry_points_calling :: IO [TestTree] -test_Entry_points_calling = - testTreesWithUntypedContract (dir <> "call1.mtz") $ \call1 -> - testTreesWithUntypedContract (dir <> "contract1.mtz") $ \contract1 -> - testTreesWithUntypedContract (dir <> "self1.mtz") $ \self1 -> - pure - -- TODO [TM-280]: Further use 'tOriginate' at least. - -- Currently it's not possible, in untyped -> typed conversion we loose - -- information about parameter annotations; to fix this, need to replace - -- all 'T.Contract' with 'T.FullContract'. - [ testCase "Calling some entrypoint in CONTRACT" $ - integrationalTestExpectation $ do - callerRef <- originate call1 "caller" (T.untypeValue $ toVal ()) (toMutez 100) - targetRef <- originate contract1 "target" (T.untypeValue $ toVal @Integer 0) (toMutez 100) - - tTransfer (#from .! genesisAddress) (#to .! callerRef) (toMutez 1) - T.DefEpName (toVal targetRef) - - validate . Right $ - tExpectStorageConst targetRef (toVal @Integer 5) - - , testCase "Calling some entrypoint in SELF" $ - integrationalTestExpectation $ do - contractRef <- originate self1 "self" (T.untypeValue $ toVal @Integer 0) (toMutez 100) - - tTransfer (#from .! genesisAddress) (#to .! contractRef) (toMutez 1) - T.DefEpName (toVal $ Right @Integer ()) - - validate . Right $ - tExpectStorageConst contractRef (toVal @Integer 5) - ] - where - dir = "contracts/entrypoints/" - ---------------------------------------------------------------------------- -validateSuccess :: HasCallStack => ContractPropValidator st Expectation -validateSuccess (res, _) = res `shouldSatisfy` isRight - validateBasic1 :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property validateBasic1 input (Right (ops, res), _) = @@ -419,8 +349,3 @@ Right ([], T.VC (CvNat x)) -> (fromInteger . toInteger) x `shouldBe` ceMaxSteps dummyContractEnv - numOfSteps _ -> expectationFailure "unexpected contract result" - -validateMichelsonFailsWith - :: (T.IsoValue v, Typeable (ToT v), SingI (ToT v)) - => v -> ContractPropValidator st Expectation -validateMichelsonFailsWith v (res, _) = res `shouldBe` Left (MichelsonFailedWith $ toVal v) diff --git a/test/Test/Interpreter/Apply.hs b/test/Test/Interpreter/Apply.hs --- a/test/Test/Interpreter/Apply.hs +++ b/test/Test/Interpreter/Apply.hs @@ -11,9 +11,11 @@ import Michelson.Test import Michelson.Typed +import Test.Util.Contracts + unit_Basic :: Assertion unit_Basic = do - (_, applyContract) <- importContract "contracts/apply.tz" + (_, applyContract) <- importContract (inContractsDir "apply.tz") let lam :: Instr '[ ToT (Integer, Integer) ] '[ ToT Integer ] lam = DUP `Seq` CAR `Seq` DIP CDR `Seq` SUB @@ -25,7 +27,7 @@ unit_Partially_applied_lambda_packed :: Assertion unit_Partially_applied_lambda_packed = do (_, partApplyContract) <- - importContract "contracts/partially-applied-lambda-packed.tz" + importContract (inContractsDir "partially-applied-lambda-packed.tz") let expected = decodeHex "05020000000f0743035b0005034202000000020316" ?: error "Bad bytes" contractProp @() @ByteString diff --git a/test/Test/Interpreter/Auction.hs b/test/Test/Interpreter/Auction.hs --- a/test/Test/Interpreter/Auction.hs +++ b/test/Test/Interpreter/Auction.hs @@ -24,6 +24,8 @@ import Tezos.Crypto (KeyHash) import Util.Test.Arbitrary (runGen) +import Test.Util.Contracts + type Storage = (Timestamp, (Mutez, KeyHash)) type Param = KeyHash @@ -33,7 +35,7 @@ -- and QuickCheck. test_Auction :: IO [TestTree] test_Auction = - testTreesWithTypedContract "contracts/tezos_examples/attic/auction.tz" auctionTest + testTreesWithTypedContract (inContractsDir "tezos_examples/attic/auction.tz") auctionTest where -- Test auction.tz, everything should be fine auctionTest contract = diff --git a/test/Test/Interpreter/Balance.hs b/test/Test/Interpreter/Balance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Interpreter/Balance.hs @@ -0,0 +1,107 @@ + +module Test.Interpreter.Balance + ( test_balanceIncludesAmount + , test_balanceIncludesAmountComplexCase + ) where + +import Test.QuickCheck (Arbitrary(..), choose, withMaxSuccess) +import Test.QuickCheck.Instances.Text () +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (testProperty) + +import Michelson.Runtime.GState +import Michelson.Test (testTreesWithUntypedContract) +import Michelson.Test.Integrational +import Michelson.Typed +import qualified Michelson.Untyped as U +import Tezos.Core + +import Test.Util.Contracts + +data Fixture = + Fixture + { fStartingBalance :: Mutez + , fAmount :: Mutez + } deriving stock (Show) + +instance Arbitrary Fixture where + arbitrary = do + fStartingBalance <- unsafeMkMutez <$> choose (1000, 5000) + fAmount <- unsafeMkMutez <$> choose (0, 1000) + return Fixture{..} + +test_balanceIncludesAmount :: IO [TestTree] +test_balanceIncludesAmount = do + testTreesWithUntypedContract + (inContractsDir "check_if_balance_includes_incoming_amount.tz") $ + \checker -> + pure + [ testProperty "BALANCE includes AMOUNT" $ withMaxSuccess 50 $ + integrationalTestProperty . scenario checker + ] + where + scenario :: U.Contract -> Fixture -> IntegrationalScenario + scenario checker Fixture{..} = do + let result = unsafeAddMutez fStartingBalance fAmount + + address <- originate + checker + "checkIfBalanceIncludeAmount" + (untypeValue $ toVal ()) + fStartingBalance + + let + txData = TxData + { tdSenderAddress = genesisAddress + , tdParameter = untypeValue $ toVal result + , tdEntrypoint = DefEpName + , tdAmount = fAmount + } + + transfer txData address + validate + $ Right + $ expectBalance address result + +test_balanceIncludesAmountComplexCase :: IO [TestTree] +test_balanceIncludesAmountComplexCase = do + testTreesWithUntypedContract (inContractsDir "balance_test_case_a.tz") $ \contractA -> + testTreesWithUntypedContract (inContractsDir "balance_test_case_b.tz") $ \contractB -> + pure + [ testCase "BALANCE returns expected value in nested calls" + $ integrationalTestExpectation + $ scenario contractA contractB + ] + where + scenario :: U.Contract -> U.Contract -> IntegrationalScenario + scenario contractA contractB = do + addressA <- originate + contractA + "balance_test_case_a" + (untypeValue $ toVal @[Mutez] []) + (unsafeMkMutez 0) + + addressB <- originate + contractB + "balance_test_case_b" + (untypeValue $ toVal ()) + (unsafeMkMutez 0) + + let + txData = TxData + { tdSenderAddress = genesisAddress + , tdParameter = untypeValue $ toVal addressB + , tdEntrypoint = DefEpName + , tdAmount = unsafeMkMutez 100 + } + + transfer txData addressA + + -- A sends 30 to B, then B sends 5 back to A. A records call to BALANCE at each entry. + -- We expect that 5 mutez sent back are included in the second call to BALANCE. + validate + $ Right + $ expectStorageConst addressA + $ untypeValue + $ toVal [unsafeMkMutez 75, unsafeMkMutez 100] diff --git a/test/Test/Interpreter/CallSelf.hs b/test/Test/Interpreter/CallSelf.hs --- a/test/Test/Interpreter/CallSelf.hs +++ b/test/Test/Interpreter/CallSelf.hs @@ -20,9 +20,11 @@ import Tezos.Address (Address) import Tezos.Core (unsafeMkMutez) +import Test.Util.Contracts + test_self_caller :: IO [TestTree] test_self_caller = - testTreesWithContract "contracts/call_self_several_times.tz" $ \selfCaller -> + testTreesWithContract (inContractsDir "call_self_several_times.tz") $ \selfCaller -> pure (testImpl selfCaller) data Fixture = Fixture @@ -54,7 +56,7 @@ type Storage = 'Tc 'CNat testImpl :: - (U.Contract, Contract Parameter Storage) + (U.Contract, FullContract Parameter Storage) -> [TestTree] testImpl (uSelfCaller, selfCaller) = [ testCase ("With parameter 1 single execution consumes " <> diff --git a/test/Test/Interpreter/Compare.hs b/test/Test/Interpreter/Compare.hs --- a/test/Test/Interpreter/Compare.hs +++ b/test/Test/Interpreter/Compare.hs @@ -16,6 +16,8 @@ import qualified Michelson.Typed as T import Tezos.Core (Mutez, unsafeMkMutez) +import Test.Util.Contracts + type Param = (Mutez, Mutez) type ContractStorage = T.Value (ToT [Bool]) type ContractResult x @@ -25,7 +27,7 @@ -- | Spec to test compare.tz contract. test_compare :: IO [TestTree] test_compare = - testTreesWithTypedContract "contracts/tezos_examples/macros/compare.tz" $ \contract -> + testTreesWithTypedContract (inContractsDir "tezos_examples/macros/compare.tz") $ \contract -> let contractProp' inputParam = contractProp contract (validate (mkExpected inputParam)) diff --git a/test/Test/Interpreter/ComparePairs.hs b/test/Test/Interpreter/ComparePairs.hs --- a/test/Test/Interpreter/ComparePairs.hs +++ b/test/Test/Interpreter/ComparePairs.hs @@ -16,6 +16,8 @@ import qualified Michelson.Typed as T import Tezos.Core (Mutez, unsafeMkMutez) +import Test.Util.Contracts + type Param = ((Mutez, Mutez), (Mutez, Mutez)) type ContractStorage = T.Value (ToT [Bool]) type ContractResult x @@ -25,7 +27,7 @@ -- | Spec to test compare.tz contract. test_compare_pairs :: IO [TestTree] test_compare_pairs = - testTreesWithTypedContract "contracts/compare_pairs.tz" $ \contract -> + testTreesWithTypedContract (inContractsDir "compare_pairs.tz") $ \contract -> let contractProp' inputParam = contractProp contract (validate (mkExpected inputParam)) diff --git a/test/Test/Interpreter/Conditionals.hs b/test/Test/Interpreter/Conditionals.hs --- a/test/Test/Interpreter/Conditionals.hs +++ b/test/Test/Interpreter/Conditionals.hs @@ -17,6 +17,8 @@ import Michelson.Typed (CValue(..), ToT) import qualified Michelson.Typed as T +import Test.Util.Contracts + type Param = Either MText (Maybe Integer) type ContractStorage = T.Value (ToT MText) type ContractResult x @@ -26,7 +28,7 @@ -- | Spec to test conditionals.tz contract. test_conditionals :: IO [TestTree] test_conditionals = - testTreesWithTypedContract "contracts/tezos_examples/attic/conditionals.tz" $ \contract -> + testTreesWithTypedContract (inContractsDir "tezos_examples/attic/conditionals.tz") $ \contract -> let contractProp' inputParam = contractProp contract (validate inputParam) dummyContractEnv inputParam diff --git a/test/Test/Interpreter/ContractOp.hs b/test/Test/Interpreter/ContractOp.hs --- a/test/Test/Interpreter/ContractOp.hs +++ b/test/Test/Interpreter/ContractOp.hs @@ -10,14 +10,16 @@ import Michelson.Interpret (ContractEnv(..), ContractReturn) import Michelson.Test (contractProp, dummyContractEnv, failedProp, testTreesWithTypedContract) -import Michelson.Typed (Contract, ToT, fromVal) +import Michelson.Typed (FullContract, ToT, fromVal) import Michelson.Untyped (CT(..), T(..), Type(..), noAnn) import Tezos.Address +import Test.Util.Contracts + -- | Spec to test compare.tz contract. test_contract_op :: IO [TestTree] test_contract_op = - testTreesWithTypedContract "contracts/contract_op.tz" $ \contract -> pure + testTreesWithTypedContract (inContractsDir "contract_op.tz") $ \contract -> pure [ testProperty "contract not found" $ contractProp' False [] contract , testProperty "contract found, expected parameter is int :q, actual is int :q" $ @@ -45,7 +47,7 @@ validate _ (Left _, _) = failedProp "Unexpected fail in interepreter" validate _ _ = failedProp "Unexpected result of script execution" - contractProp' :: Bool -> [(ContractHash, Type)] -> Contract (ToT Address) (ToT Bool) -> Property + contractProp' :: Bool -> [(ContractHash, Type)] -> FullContract (ToT Address) (ToT Bool) -> Property contractProp' res ctrs contract = contractProp contract diff --git a/test/Test/Interpreter/EnvironmentSpec.hs b/test/Test/Interpreter/EnvironmentSpec.hs --- a/test/Test/Interpreter/EnvironmentSpec.hs +++ b/test/Test/Interpreter/EnvironmentSpec.hs @@ -21,11 +21,16 @@ import Tezos.Core import Tezos.Crypto (detSecretKey, toPublic) +import Test.Util.Contracts + test_environment :: IO [TestTree] test_environment = - testTreesWithContract "contracts/environment.tz" $ \contract -> - pure [ testImpl contract - , testCase ("Default balance") $ integrationalTestExpectation testDefaultBalance ] + testTreesWithContract (inContractsDir "deprecated/environment.tz") $ + \contract -> pure + [ testImpl contract + , testCase ("Default balance") $ + integrationalTestExpectation testDefaultBalance + ] data Fixture = Fixture { fNow :: Timestamp @@ -47,7 +52,7 @@ shouldExpectFailed :: Fixture -> Bool shouldExpectFailed fixture = or - [ fBalance fixture > unsafeMkMutez 1000 + [ fBalance fixture `unsafeAddMutez` fAmount fixture > unsafeMkMutez 1000 , fNow fixture < timestampFromSeconds 100500 , fPassOriginatedAddress fixture , fAmount fixture < unsafeMkMutez 15 @@ -61,7 +66,7 @@ consumedGas = 19 testImpl :: - (U.Contract, T.Contract ('Tc 'CAddress) ('Tc 'CBool)) + (U.Contract, T.FullContract ('Tc 'CAddress) ('Tc 'CBool)) -> TestTree testImpl (uEnvironment, _environment) = do testProperty description $ diff --git a/test/Test/Interpreter/StackRef.hs b/test/Test/Interpreter/StackRef.hs --- a/test/Test/Interpreter/StackRef.hs +++ b/test/Test/Interpreter/StackRef.hs @@ -15,12 +15,19 @@ test_mkStackRef :: TestTree test_mkStackRef = testCase "does not segfault" $ - contractProp contract (flip shouldSatisfy isRight . fst) + contractProp fullContract (flip shouldSatisfy isRight . fst) dummyContractEnv () () where stackRef = PrintComment . one . Right $ mkStackRef @1 - contract :: Contract 'TUnit 'TUnit - contract = + fullContract :: FullContract 'TUnit 'TUnit + fullContract = FullContract + { fcCode = contractCode + , fcStoreNotes = starNotes + , fcParamNotesSafe = starParamNotes + } + + contractCode :: ContractCode 'TUnit 'TUnit + contractCode = CAR `Seq` DUP `Seq` Ext (PRINT stackRef) `Seq` DROP `Seq` NIL `Seq` PAIR diff --git a/test/Test/Interpreter/StringCaller.hs b/test/Test/Interpreter/StringCaller.hs --- a/test/Test/Interpreter/StringCaller.hs +++ b/test/Test/Interpreter/StringCaller.hs @@ -9,8 +9,8 @@ import Test.QuickCheck (withMaxSuccess) import Test.QuickCheck.Instances.Text () import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (testProperty) import Michelson.Runtime.GState import Michelson.Test (testTreesWithContract) @@ -22,15 +22,18 @@ import Tezos.Address import Tezos.Core +import Test.Util.Contracts + test_stringCaller :: IO [TestTree] test_stringCaller = - testTreesWithContract "contracts/string_caller.tz" $ \stringCaller -> - testTreesWithContract "contracts/fail_or_store_and_transfer.tz" $ \failOrStoreAndTransfer -> - pure $ testImpl stringCaller failOrStoreAndTransfer + testTreesWithContract (inContractsDir "string_caller.tz") $ \stringCaller -> + testTreesWithContract (inContractsDir "fail_or_store_and_transfer.tz") $ + \failOrStoreAndTransfer -> + pure $ testImpl stringCaller failOrStoreAndTransfer testImpl :: - (U.Contract, T.Contract ('Tc 'CString) ('Tc 'CAddress)) - -> (U.Contract, T.Contract ('Tc 'CString) ('Tc 'CString)) + (U.Contract, T.FullContract ('Tc 'CString) ('Tc 'CAddress)) + -> (U.Contract, T.FullContract ('Tc 'CString) ('Tc 'CString)) -> [TestTree] testImpl (uStringCaller, _stringCaller) (uFailOrStore, _failOrStoreAndTransfer) = let scenario = integrationalScenario uStringCaller uFailOrStore @@ -38,7 +41,7 @@ "stringCaller calls failOrStoreAndTransfer and updates its storage with " suffix = " and properly updates balances. But fails if failOrStoreAndTransfer's" - <> " balance is ≥ 1000 and NOW is ≥ 500" + <> " balance is ≥ 1300 and NOW is ≥ 500" in [ testCase (prefix <> "a constant" <> suffix) $ integrationalTestExpectation (scenario constStr) @@ -103,7 +106,7 @@ transferToStringCaller -- This time execution should fail, because failOrStoreAndTransfer should fail - -- because its balance is greater than 1000. + -- because its balance is greater than 1300. void $ validate (Left $ expectMichelsonFailed (const True) failOrStoreAndTransferAddress) -- We can also send tokens from failOrStoreAndTransfer to tz1 address directly diff --git a/test/Test/Michelson/Runtime.hs b/test/Test/Michelson/Runtime.hs --- a/test/Test/Michelson/Runtime.hs +++ b/test/Test/Michelson/Runtime.hs @@ -6,6 +6,7 @@ import Control.Lens (at) import Fmt (pretty) +import System.FilePath (()) import Test.Hspec.Expectations (Expectation, expectationFailure, shouldSatisfy) import Test.HUnit (Assertion, assertFailure, (@?=)) import Test.Tasty (TestTree, testGroup) @@ -25,10 +26,12 @@ import Tezos.Address import Tezos.Core (unsafeMkMutez) +import Test.Util.Contracts (contractsDir) + test_executorPure :: IO [TestTree] test_executorPure = do illTypedContract <- - prepareContract (Just "contracts/ill-typed/sum_strings.tz") + prepareContract (Just (contractsDir "ill-typed/sum_strings.tz")) pure [ testGroup "Updates storage value of executed contract" $ [ testCase "contract1" $ updatesStorageValue contractAux1 diff --git a/test/Test/OpSize.hs b/test/Test/OpSize.hs --- a/test/Test/OpSize.hs +++ b/test/Test/OpSize.hs @@ -184,12 +184,14 @@ , typeTestCase "lambda operation int" 12 , typeTestCase "pair int int" 12 + , typeTestCase "pair (int : %) int" 12 , typeTestCase "pair (int :a) int" 18 , typeTestCase "pair (int %a) int" 18 , typeTestCase "pair (int %a :a) int" 21 , typeTestCase "pair (int %a) (int %a)" 24 , typeTestCase "pair :a (int %a) (int %a)" 30 , typeTestCase "pair :a int (int %a)" 24 + , typeTestCase "pair : (int %a :) (int %a)" 24 , typeTestCase "pair :a (int %a :a) (int %a)" 33 ] where @@ -202,6 +204,7 @@ , customInstrTestCase "FAIL" 9 , instrTestCase "DUP" 4 + , instrTestCase "DUP @" 4 , instrTestCase "DUP @a" 10 , instrTestCase "DUP; DROP" 6 , instrTestCase "DUP; SWAP" 6 @@ -210,7 +213,7 @@ , instrTestCase "PUSH @a int 0" 14 , instrTestCase "PUSH @a (int :a) 0" 20 , instrTestCase "SOME" 4 - , instrTestCase "SOME @a" 10 + , instrTestCase "SOME @" 4 , instrTestCase "SOME @a" 10 , instrTestCase "NONE int" 6 , instrTestCase "NONE (option int)" 8 @@ -218,9 +221,12 @@ , instrTestCase "UNIT" 4 , instrTestCase "DUP; SOME; IF_NONE {}{DROP}" 20 , instrTestCase "DUP; DUP; PAIR" 8 + , instrTestCase "DUP; DUP; PAIR % % : @" 8 , instrTestCase "DUP; DUP; PAIR %a" 14 , instrTestCase "DUP; DUP; PAIR %a %a" 17 , instrTestCase "DUP; DUP; PAIR %a %a :a" 20 + , instrTestCase "DUP; DUP; PAIR %a % :a @a" 20 + , instrTestCase "DUP; DUP; PAIR % %a :a @a" 23 , instrTestCase "DUP; DUP; PAIR %a %a :a @a" 23 -- Further skipping some instructions since everything is trivial , instrTestCase "EMPTY_BIG_MAP :a @a (int :a) (unit :a)" 29 diff --git a/test/Test/Optimizer.hs b/test/Test/Optimizer.hs --- a/test/Test/Optimizer.hs +++ b/test/Test/Optimizer.hs @@ -4,10 +4,14 @@ ( unit_Optimize_DROP_n , unit_Optimize_DIP_n , unit_Redundant_DIP + , unit_Adjacent_DIPs + , unit_Nested_adjacent_DIPs , unit_UNPAIR_DROP + , unit_Specific_PUSH , unit_Optimize_PUSH_PACK , unit_Optimizer_Tree_Independence , unit_Sample_optimize + , unit_Pair_Unpair ) where import Prelude hiding (EQ) @@ -54,12 +58,33 @@ optimize @Stack1Int @Stack1 (DIP UNIT `Seq` DROP) @?= (DROP `Seq` UNIT) optimize @Stack1Int @Stack2UnitInt (UNIT `Seq` DIP (DUP `Seq` MUL)) @?= (DUP `Seq` MUL `Seq` UNIT) +unit_Adjacent_DIPs :: Assertion +unit_Adjacent_DIPs = do + optimize (DIP (PUSH strValue) `Seq` DIP (PUSH strValue)) @?= (DIP (PUSH strValue `Seq` PUSH strValue)) + optimize + (DIP (PUSH strValue) `Seq` + DIP UNIT `Seq` + DIP PAIR) + @?= (DIP (PUSH strValue `Seq` UNIT `Seq` PAIR)) + +unit_Nested_adjacent_DIPs :: Assertion +unit_Nested_adjacent_DIPs = do + optimize + (IF_NONE (PUSH strValue) (DIP (PUSH strValue) `Seq` DIP (PUSH strValue) `Seq` DIP CONCAT `Seq` CONCAT)) + @?= (IF_NONE (PUSH strValue) (DIP (PUSH strValue `Seq` PUSH strValue `Seq` CONCAT) `Seq` CONCAT)) + unit_UNPAIR_DROP :: Assertion unit_UNPAIR_DROP = do -- The left is `unpair # DROP` which is essentially just `cdr`, -- but we do not optimize it fully yet (we only remove redundant DIP). optimize @Stack1Pair @Stack1 (DUP `Seq` CAR `Seq` DIP CDR `Seq` DROP) @?= (DUP `Seq` CAR `Seq` DROP `Seq` CDR) +unit_Specific_PUSH :: Assertion +unit_Specific_PUSH = do + optimize (PUSH (T.VMap @'CInt @'T.TUnit mempty)) @?= EMPTY_MAP + optimize (PUSH (T.VSet @'CInt mempty) `Seq` NOW) @?= (EMPTY_SET `Seq` NOW) + optimize (PUSH T.VUnit) @?= UNIT + unit_Optimize_PUSH_PACK :: Assertion unit_Optimize_PUSH_PACK = optimize' @@ -73,13 +98,19 @@ unit_Sample_optimize :: Assertion unit_Sample_optimize = optimize nonOptimal @?= expectedOptimized +unit_Pair_Unpair :: Assertion +unit_Pair_Unpair = + optimize + (PAIR `Seq` UNPAIR `Seq` UNPAIR `Seq` PAIR) @?= + Nop + str :: MText str = [mt|aa|] strValue :: T.Value ('T.Tc 'CString) strValue = T.VC $ T.CvString str -nonOptimal :: T.Contract ('T.Tc 'CString) ('T.Tc 'CString) +nonOptimal :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString) nonOptimal = CAR `Seq` -- `PUSH; DROP` is erased @@ -116,7 +147,7 @@ infixr 1 #<# -- Expected output of the optimizer. -expectedOptimized :: T.Contract ('T.Tc 'CString) ('T.Tc 'CString) +expectedOptimized :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString) expectedOptimized = CAR #<# DUP #<# diff --git a/test/Test/Preprocess.hs b/test/Test/Preprocess.hs --- a/test/Test/Preprocess.hs +++ b/test/Test/Preprocess.hs @@ -31,7 +31,7 @@ str4 = [mt|naiks|] str5 = [mt|eek|] -sample :: T.Contract ('T.Tc 'CString) ('T.Tc 'CString) +sample :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString) sample = CAR `Seq` PUSH (toStr str1) `Seq` @@ -44,7 +44,7 @@ where toStr = T.VC . T.CvString -expected :: T.Contract ('T.Tc 'CString) ('T.Tc 'CString) +expected :: T.ContractCode ('T.Tc 'CString) ('T.Tc 'CString) expected = CAR `Seq` PUSH (toStr str5) `Seq` diff --git a/test/Test/Printer/Michelson.hs b/test/Test/Printer/Michelson.hs --- a/test/Test/Printer/Michelson.hs +++ b/test/Test/Printer/Michelson.hs @@ -6,6 +6,7 @@ , unit_PrettyPrint , unit_PrintTypedNotes , unit_PrintSmartParens + , unit_PrintBigDipN ) where import qualified Data.Map.Lazy as Map @@ -42,17 +43,22 @@ unit_PrintTypedNotes :: Assertion unit_PrintTypedNotes = do - contracts <- getContractsWithReferences ".tz" "contracts/notes-in-typed-contracts" "ref" + contracts <- getContractsWithReferences ".tz" (inContractsDir "notes-in-typed-contracts") "ref" mapM_ printerTest contracts unit_PrintSmartParens :: Assertion unit_PrintSmartParens = do - contracts <- getContractsWithReferences ".tz" "contracts/smart-parens" "ref" + contracts <- getContractsWithReferences ".tz" (inContractsDir "smart-parens") "ref" mapM_ printerTest contracts +unit_PrintBigDipN :: Assertion +unit_PrintBigDipN = do + contracts <- getContractsWithReferences ".tz" (inContractsDir "big-dip") "ref" + mapM_ printerTest contracts + unit_PrettyPrint :: Assertion unit_PrettyPrint = do - contracts <- getContractsWithReferences ".tz" "contracts/pretty" "pretty" + contracts <- getContractsWithReferences ".tz" (inContractsDir "pretty") "pretty" mapM_ prettyTest contracts where prettyTest :: (FilePath, FilePath) -> Assertion @@ -96,7 +102,7 @@ unit_let_macro :: Assertion unit_let_macro = do - let filePath = "contracts/ill-typed/letblock_trivial.mtz" + let filePath = inContractsDir "ill-typed/letblock_trivial.mtz" contract <- printAndParse filePath =<< importUntypedContract filePath let ops = concatMap U.flattenExpandedOp (U.code contract) ops @?= [U.CDR U.noAnn U.noAnn, U.UNIT U.noAnn U.noAnn, U.DROP] diff --git a/test/Test/Serialization/Michelson.hs b/test/Test/Serialization/Michelson.hs --- a/test/Test/Serialization/Michelson.hs +++ b/test/Test/Serialization/Michelson.hs @@ -168,7 +168,7 @@ | length s < 60 = s | otherwise = take 60 s <> " ..." initTypeCheckST = error "Type check state is not defined" - initStack = (sing @inp, starNotes, noAnn) ::& SNil + initStack = (starNotes @inp, noAnn) ::& SNil unpackNegSpec :: forall (t :: T). @@ -641,6 +641,11 @@ -- ADDRESS goes below , "CHAIN_ID; DROP" ~: "0x05020000000403750320" + -- DUP macro + , "PUSH nat 1; PUSH nat 1; DUP 2; DROP; DROP; DROP" + ~: "0x050200000022074303620001074303620001020000000b051f02000000020321034c032003200320" + , "PUSH nat 1; PUSH nat 1; DUUP; DROP; DROP; DROP" + ~: "0x050200000022074303620001074303620001020000000b051f02000000020321034c032003200320" ] parsePackSpec @'TUnit @'TUnit "arith instr" diff --git a/test/Test/Typecheck.hs b/test/Test/Typecheck.hs --- a/test/Test/Typecheck.hs +++ b/test/Test/Typecheck.hs @@ -41,7 +41,7 @@ import Tezos.Core (Timestamp) import Util.IO (readFileUtf8) -import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts) +import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts, inContractsDir) unit_Good_contracts :: Assertion unit_Good_contracts = mapM_ (\f -> checkFile [] True f (const pass)) =<< getWellTypedContracts @@ -55,23 +55,23 @@ test_srcPosition :: [TestTree] test_srcPosition = [ testProperty "Verify instruction position in a typecheck error" $ do - checkIllFile "contracts/ill-typed/basic3.tz" $ \case + checkIllFile (inContractsDir "ill-typed/basic3.tz") $ \case TCFailedOnInstr (Un.CONS _) _ _ (IsSrcPos 4 6) (Just (AnnError _)) -> True _ -> False - checkIllFile "contracts/ill-typed/testassert_invalid_stack3.mtz" $ \case + checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack3.mtz") $ \case TCFailedOnInstr Un.DROP _ _ (IsSrcPos 6 17) Nothing -> True _ -> False - checkIllFile "contracts/ill-typed/testassert_invalid_stack2.mtz" $ \case + checkIllFile (inContractsDir "ill-typed/testassert_invalid_stack2.mtz") $ \case TCExtError _ (IsSrcPos 5 2) (TestAssertError _) -> True _ -> False - checkIllFile "contracts/ill-typed/macro_in_let_fail.mtz" $ \case + checkIllFile (inContractsDir "ill-typed/macro_in_let_fail.mtz") $ \case TCFailedOnInstr (Un.COMPARE _) _ _ (InstrCallStack [LetName "cmpLet"] (SrcPos (Pos 3) (Pos 6))) (Just (TypeEqError _ _)) -> True _ -> False - checkIllFile "contracts/ill-typed/compare_annotation_mismatch.tz" $ \case + checkIllFile (inContractsDir "ill-typed/compare_annotation_mismatch.tz") $ \case TCFailedOnInstr (Un.COMPARE _) _ _ _ (Just (AnnError _)) -> True _ -> False ] @@ -106,7 +106,7 @@ unit_Unreachable_code :: Assertion unit_Unreachable_code = do - let file = "contracts/ill-typed/fail_before_nop.tz" + let file = inContractsDir "ill-typed/fail_before_nop.tz" let ics = InstrCallStack [] (srcPos 3 13) econtract <- readContract @'T.TUnit @'T.TUnit file <$> readFileUtf8 file econtract @?= Left (ICETypeCheck $ TCUnreachableCode ics (one $ Un.WithSrcEx ics $ Un.SeqEx [])) @@ -130,7 +130,7 @@ property $ \(val :: T.Value (T.ToT a)) -> let uval = T.untypeValue val runTC = runTypeCheckIsolated . usingReaderT (def @InstrCallStack) - in case runTC $ typeVerifyValue uval of + in case runTC $ typeCheckValue uval of Right got -> got @?= val Left err -> expectationFailure $ "Type check unexpectedly failed: " <> pretty err @@ -161,7 +161,7 @@ ] where printStRef i = Un.EXT . Un.UPRINT $ Un.PrintComment [Right (Un.StackRef i)] - stackEl = (sing @'T.TUnit, T.starNotes, noAnn) + stackEl = (T.starNotes @'T.TUnit, noAnn) test_TCTypeError_display :: [TestTree] test_TCTypeError_display = @@ -193,21 +193,21 @@ untypedValue = Un.ValueSeq $ Un.ValueInt <$> l typedValue = T.VList $ (T.VC . T.CvInt) <$> toList l runTypeCheckInstr = runTypeCheckIsolated . usingReaderT def - in runTypeCheckInstr (typeVerifyValue untypedValue) == Right typedValue + in runTypeCheckInstr (typeCheckValue untypedValue) == Right typedValue test_SELF :: [TestTree] test_SELF = [ testCase "Entrypoint not present" $ - checkFile [] False "contracts/ill-typed/self-bad-entrypoint.mtz" $ \case + checkFile [] False (inContractsDir "ill-typed/self-bad-entrypoint.mtz") $ \case TCFailedOnInstr Un.SELF{} _ _ _ (Just EntryPointNotFound{}) -> pass other -> assertFailure $ "Unexpected error: " <> pretty other , testCase "Entrypoint type mismatch" $ - checkFile [] False "contracts/ill-typed/self-entrypoint-type-mismatch.mtz" + checkFile [] False (inContractsDir "ill-typed/self-entrypoint-type-mismatch.mtz") (const pass) , testCase "Entrypoint can be found" $ - checkFile [] True "contracts/entrypoints/self1.mtz" + checkFile [] True (inContractsDir "entrypoints/self1.mtz") (const pass) ] @@ -242,8 +242,8 @@ ] doTypeCheckVal - :: (Typeable t, SingI t) + :: SingI t => TcOriginatedContracts -> Un.Value -> Either TCError (T.Value t) doTypeCheckVal env uval = runTypeCheck (error "hello there") env $ usingReaderT def $ - typeVerifyValue uval + typeCheckValue uval diff --git a/test/Test/Util/Contracts.hs b/test/Test/Util/Contracts.hs --- a/test/Test/Util/Contracts.hs +++ b/test/Test/Util/Contracts.hs @@ -1,29 +1,41 @@ -- | Utility functions to read sample contracts (for testing). module Test.Util.Contracts - ( getIllTypedContracts - , getWellTypedContracts - , getUnparsableContracts - , getWellTypedMichelsonContracts - , getWellTypedMorleyContracts - , getContractsWithReferences - ) where + ( contractsDir + , inContractsDir + , () + , getIllTypedContracts + , getWellTypedContracts + , getUnparsableContracts + , getWellTypedMichelsonContracts + , getWellTypedMorleyContracts + , getContractsWithReferences + ) where + import Data.List (isSuffixOf) import System.Directory (listDirectory) import System.FilePath (addExtension, ()) +-- | Directory with sample contracts. +contractsDir :: FilePath +contractsDir = "../../contracts/" + +inContractsDir :: FilePath -> FilePath +inContractsDir = (contractsDir ) + getIllTypedContracts :: IO [FilePath] getIllTypedContracts = - concatMapM (flip getContractsWithExtension "contracts/ill-typed") - [".tz", ".mtz"] + concatMapM (\ext -> + concatMapM (getContractsWithExtension ext) illTypedContractDirs + ) [".tz", ".mtz"] getWellTypedContracts :: IO [FilePath] getWellTypedContracts = getWellTypedMichelsonContracts <> getWellTypedMorleyContracts getUnparsableContracts :: IO [FilePath] getUnparsableContracts = - concatMapM (flip getContractsWithExtension "contracts/unparsable") + concatMapM (flip getContractsWithExtension (contractsDir "unparsable")) [".tz", ".mtz"] getWellTypedMichelsonContracts :: IO [FilePath] @@ -44,13 +56,21 @@ wellTypedContractDirs :: [FilePath] wellTypedContractDirs = - "contracts" : - map (("contracts" "tezos_examples") ) + contractsDir : + map ((contractsDir "tezos_examples") ) [ "attic" + -- , "entrypoints" + -- ^ TODO: uncomment once https://gitlab.com/morley-framework/morley/issues/35 is resolved , "macros" , "mini_scenarios" , "opcodes" ] + +illTypedContractDirs :: [FilePath] +illTypedContractDirs = + [ contractsDir "ill-typed" + , contractsDir "tezos_examples" "ill_typed" + ] getContractsWithReferences :: String -> FilePath -> String -> IO [(FilePath, FilePath)] getContractsWithReferences ext fp refExt =